guile18/srfi/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, 2008
   4  *      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
   8  * License as published by the Free Software Foundation; either
   9  * version 2.1 of the License, or (at your option) any later version.
  10  *
  11  * This library is distributed in the hope that it will be useful,
  12  * but 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 02110-1301 USA
  19  */
  20
  21 #ifdef HAVE_CONFIG_H
  22 # include <config.h>
  23 #endif
  24
  25 #include <libguile.h>
  26 #include <libguile/lang.h>
  27
  28 #include "srfi-1.h"
  29
  30 /* The intent of this file is to gradually replace those Scheme
  31  * procedures in srfi-1.scm which extends core primitive procedures,
  32  * so that using srfi-1 won't have performance penalties.
  33  *
  34  * Please feel free to contribute any new replacements!
  35  */
  36
  37 static long
  38 srfi1_ilength (SCM sx)
  39 {
  40   long i = 0;
  41   SCM tortoise = sx;
  42   SCM hare = sx;
  43
  44   do {
  45     if (SCM_NULL_OR_NIL_P(hare)) return i;
  46     if (!scm_is_pair (hare)) return -2;
  47     hare = SCM_CDR(hare);
  48     i++;
  49     if (SCM_NULL_OR_NIL_P(hare)) return i;
  50     if (!scm_is_pair (hare)) return -2;
  51     hare = SCM_CDR(hare);
  52     i++;
  53     /* For every two steps the hare takes, the tortoise takes one.  */
  54     tortoise = SCM_CDR(tortoise);
  55   }
  56   while (! scm_is_eq (hare, tortoise));
  57
  58   /* If the tortoise ever catches the hare, then the list must contain
  59      a cycle.  */
  60   return -1;
  61 }
  62
  63 static SCM
  64 equal_trampoline (SCM proc, SCM arg1, SCM arg2)
  65 {
  66   return scm_equal_p (arg1, arg2);
  67 }
  68
  69 /* list_copy_part() copies the first COUNT cells of LST, puts the result at
  70    *dst, and returns the SCM_CDRLOC of the last cell in that new list.
  71
  72    This function is designed to be careful about LST possibly having changed
  73    in between the caller deciding what to copy, and the copy actually being
  74    done here.  The COUNT ensures we terminate if LST has become circular,
  75    SCM_VALIDATE_CONS guards against a cdr in the list changed to some
  76    non-pair object.  */
  77
  78 #include <stdio.h>
  79 static SCM *
  80 list_copy_part (SCM lst, int count, SCM *dst)
  81 #define FUNC_NAME "list_copy_part"
  82 {
  83   SCM c;
  84   for ( ; count > 0; count--)
  85     {
  86       SCM_VALIDATE_CONS (SCM_ARGn, lst);
  87       c = scm_cons (SCM_CAR (lst), SCM_EOL);
  88       *dst = c;
  89       dst = SCM_CDRLOC (c);
  90       lst = SCM_CDR (lst);
  91     }
  92   return dst;
  93 }
  94 #undef FUNC_NAME
  95
  96
  97 SCM_DEFINE (scm_srfi1_alist_copy, "alist-copy", 1, 0, 0,
  98             (SCM alist),
  99             "Return a copy of @var{alist}, copying both the pairs comprising\n"
 100             "the list and those making the associations.")
 101 #define FUNC_NAME s_scm_srfi1_alist_copy
 102 {
 103   SCM  ret, *p, elem, c;
 104
 105   /* ret is the list to return.  p is where to append to it, initially &ret
 106      then SCM_CDRLOC of the last pair.  */
 107   ret = SCM_EOL;
 108   p = &ret;
 109
 110   for ( ; scm_is_pair (alist); alist = SCM_CDR (alist))
 111     {
 112       elem = SCM_CAR (alist);
 113
 114       /* each element of alist must be a pair */
 115       SCM_ASSERT_TYPE (scm_is_pair (elem), alist, SCM_ARG1, FUNC_NAME,
 116                        "association list");
 117
 118       c = scm_cons (scm_cons (SCM_CAR (elem), SCM_CDR (elem)), SCM_EOL);
 119       *p = c;
 120       p = SCM_CDRLOC (c);
 121     }
 122
 123   /* alist must be a proper list */
 124   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (alist), alist, SCM_ARG1, FUNC_NAME,
 125                    "association list");
 126   return ret;
 127 }
 128 #undef FUNC_NAME
 129
 130
 131
 132 SCM_DEFINE (scm_srfi1_append_reverse, "append-reverse", 2, 0, 0,
 133             (SCM revhead, SCM tail),
 134             "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
 135             "result.  This is equivalent to @code{(append (reverse\n"
 136             "@var{rev-head}) @var{tail})}, but its implementation is more\n"
 137             "efficient.\n"
 138             "\n"
 139             "@example\n"
 140             "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
 141             "@end example")
 142 #define FUNC_NAME s_scm_srfi1_append_reverse
 143 {
 144   while (scm_is_pair (revhead))
 145     {
 146       /* copy first element of revhead onto front of tail */
 147       tail = scm_cons (SCM_CAR (revhead), tail);
 148       revhead = SCM_CDR (revhead);
 149     }
 150   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
 151                    "list");
 152   return tail;
 153 }
 154 #undef FUNC_NAME
 155
 156
 157 SCM_DEFINE (scm_srfi1_append_reverse_x, "append-reverse!", 2, 0, 0,
 158             (SCM revhead, SCM tail),
 159             "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
 160             "result.  This is equivalent to @code{(append! (reverse!\n"
 161             "@var{rev-head}) @var{tail})}, but its implementation is more\n"
 162             "efficient.\n"
 163             "\n"
 164             "@example\n"
 165             "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
 166             "@end example\n"
 167             "\n"
 168             "@var{rev-head} may be modified in order to produce the result.")
 169 #define FUNC_NAME s_scm_srfi1_append_reverse_x
 170 {
 171   SCM newtail;
 172
 173   while (scm_is_pair (revhead))
 174     {
 175       /* take the first cons cell from revhead */
 176       newtail = revhead;
 177       revhead = SCM_CDR (revhead);
 178
 179       /* make it the new start of tail, appending the previous */
 180       SCM_SETCDR (newtail, tail);
 181       tail = newtail;
 182     }
 183   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
 184                    "list");
 185   return tail;
 186 }
 187 #undef FUNC_NAME
 188
 189
 190 SCM_DEFINE (scm_srfi1_break, "break", 2, 0, 0,
 191             (SCM pred, SCM lst),
 192             "Return two values, the longest initial prefix of @var{lst}\n"
 193             "whose elements all fail the predicate @var{pred}, and the\n"
 194             "remainder of @var{lst}.\n"
 195             "\n"
 196             "Note that the name @code{break} conflicts with the @code{break}\n"
 197             "binding established by @code{while}.  Applications wanting to\n"
 198             "use @code{break} from within a @code{while} loop will need to\n"
 199             "make a new define under a different name.")
 200 #define FUNC_NAME s_scm_srfi1_break
 201 {
 202   scm_t_trampoline_1 pred_tramp;
 203   SCM ret, *p;
 204
 205   pred_tramp = scm_trampoline_1 (pred);
 206   SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
 207
 208   ret = SCM_EOL;
 209   p = &ret;
 210   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
 211     {
 212       SCM elem = SCM_CAR (lst);
 213       if (scm_is_true (pred_tramp (pred, elem)))
 214         goto done;
 215
 216       /* want this elem, tack it onto the end of ret */
 217       *p = scm_cons (elem, SCM_EOL);
 218       p = SCM_CDRLOC (*p);
 219     }
 220   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
 221
 222  done:
 223   return scm_values (scm_list_2 (ret, lst));
 224 }
 225 #undef FUNC_NAME
 226
 227
 228 SCM_DEFINE (scm_srfi1_break_x, "break!", 2, 0, 0,
 229             (SCM pred, SCM lst),
 230             "Return two values, the longest initial prefix of @var{lst}\n"
 231             "whose elements all fail the predicate @var{pred}, and the\n"
 232             "remainder of @var{lst}.  @var{lst} may be modified to form the\n"
 233             "return.")
 234 #define FUNC_NAME s_scm_srfi1_break_x
 235 {
 236   SCM upto, *p;
 237   scm_t_trampoline_1 pred_tramp;
 238
 239   pred_tramp = scm_trampoline_1 (pred);
 240   SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
 241
 242   p = &lst;
 243   for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
 244     {
 245       if (scm_is_true (pred_tramp (pred, SCM_CAR (upto))))
 246         goto done;
 247
 248       /* want this element */
 249       p = SCM_CDRLOC (upto);
 250     }
 251   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto), lst, SCM_ARG2, FUNC_NAME, "list");
 252
 253  done:
 254   *p = SCM_EOL;
 255   return scm_values (scm_list_2 (lst, upto));
 256 }
 257 #undef FUNC_NAME
 258
 259
 260 SCM_DEFINE (scm_srfi1_car_plus_cdr, "car+cdr", 1, 0, 0,
 261             (SCM pair),
 262             "Return two values, the @sc{car} and the @sc{cdr} of @var{pair}.")
 263 #define FUNC_NAME s_scm_srfi1_car_plus_cdr
 264 {
 265   SCM_VALIDATE_CONS (SCM_ARG1, pair);
 266   return scm_values (scm_list_2 (SCM_CAR (pair), SCM_CDR (pair)));
 267 }
 268 #undef FUNC_NAME
 269
 270
 271 SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0,
 272             (SCM lstlst),
 273             "Construct a list by appending all lists in @var{lstlst}.\n"
 274             "\n"
 275             "@code{concatenate} is the same as @code{(apply append\n"
 276             "@var{lstlst})}.  It exists because some Scheme implementations\n"
 277             "have a limit on the number of arguments a function takes, which\n"
 278             "the @code{apply} might exceed.  In Guile there is no such\n"
 279             "limit.")
 280 #define FUNC_NAME s_scm_srfi1_concatenate
 281 {
 282   SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
 283   return scm_append (lstlst);
 284 }
 285 #undef FUNC_NAME
 286
 287
 288 SCM_DEFINE (scm_srfi1_concatenate_x, "concatenate!", 1, 0, 0,
 289             (SCM lstlst),
 290             "Construct a list by appending all lists in @var{lstlst}.  Those\n"
 291             "lists may be modified to produce the result.\n"
 292             "\n"
 293             "@code{concatenate!} is the same as @code{(apply append!\n"
 294             "@var{lstlst})}.  It exists because some Scheme implementations\n"
 295             "have a limit on the number of arguments a function takes, which\n"
 296             "the @code{apply} might exceed.  In Guile there is no such\n"
 297             "limit.")
 298 #define FUNC_NAME s_scm_srfi1_concatenate
 299 {
 300   SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
 301   return scm_append_x (lstlst);
 302 }
 303 #undef FUNC_NAME
 304
 305
 306 SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1,
 307             (SCM pred, SCM list1, SCM rest),
 308             "Return a count of the number of times @var{pred} returns true\n"
 309             "when called on elements from the given lists.\n"
 310             "\n"
 311             "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
 312             "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
 313             "corresponding @var{list1} @dots{} @var{lstN}.  The first call is\n"
 314             "with the first element of each list, the second with the second\n"
 315             "element from each, and so on.\n"
 316             "\n"
 317             "Counting stops when the end of the shortest list is reached.\n"
 318             "At least one list must be non-circular.")
 319 #define FUNC_NAME s_scm_srfi1_count
 320 {
 321   long  count;
 322   SCM   lst;
 323   int   argnum;
 324   SCM_VALIDATE_REST_ARGUMENT (rest);
 325
 326   count = 0;
 327
 328   if (scm_is_null (rest))
 329     {
 330       /* one list */
 331       scm_t_trampoline_1 pred_tramp;
 332       pred_tramp = scm_trampoline_1 (pred);
 333       SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
 334
 335       for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
 336         count += scm_is_true (pred_tramp (pred, SCM_CAR (list1)));
 337
 338       /* check below that list1 is a proper list, and done */
 339     end_list1:
 340       lst = list1;
 341       argnum = 2;
 342     }
 343   else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
 344     {
 345       /* two lists */
 346       scm_t_trampoline_2 pred_tramp;
 347       SCM list2;
 348
 349       pred_tramp = scm_trampoline_2 (pred);
 350       SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
 351
 352       list2 = SCM_CAR (rest);
 353       for (;;)
 354         {
 355           if (! scm_is_pair (list1))
 356             goto end_list1;
 357           if (! scm_is_pair (list2))
 358             {
 359               lst = list2;
 360               argnum = 3;
 361               break;
 362             }
 363           count += scm_is_true (pred_tramp
 364                                 (pred, SCM_CAR (list1), SCM_CAR (list2)));
 365           list1 = SCM_CDR (list1);
 366           list2 = SCM_CDR (list2);
 367         }
 368     }
 369   else
 370     {
 371       /* three or more lists */
 372       SCM  vec, args, a;
 373       size_t  len, i;
 374
 375       /* vec is the list arguments */
 376       vec = scm_vector (scm_cons (list1, rest));
 377       len = SCM_SIMPLE_VECTOR_LENGTH (vec);
 378
 379       /* args is the argument list to pass to pred, same length as vec,
 380          re-used for each call */
 381       args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
 382
 383       for (;;)
 384         {
 385           /* first elem of each list in vec into args, and step those
 386              vec entries onto their next element */
 387           for (i = 0, a = args, argnum = 2;
 388                i < len;
 389                i++, a = SCM_CDR (a), argnum++)
 390             {
 391               lst = SCM_SIMPLE_VECTOR_REF (vec, i);  /* list argument */
 392               if (! scm_is_pair (lst))
 393                 goto check_lst_and_done;
 394               SCM_SETCAR (a, SCM_CAR (lst));  /* arg for pred */
 395               SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst));  /* rest of lst */
 396             }
 397
 398           count += scm_is_true (scm_apply (pred, args, SCM_EOL));
 399         }
 400     }
 401
 402  check_lst_and_done:
 403   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
 404   return scm_from_long (count);
 405 }
 406 #undef FUNC_NAME
 407
 408
 409 SCM_DEFINE (scm_srfi1_delete, "delete", 2, 1, 0,
 410             (SCM x, SCM lst, SCM pred),
 411             "Return a list containing the elements of @var{lst} but with\n"
 412             "those equal to @var{x} deleted.  The returned elements will be\n"
 413             "in the same order as they were in @var{lst}.\n"
 414             "\n"
 415             "Equality is determined by @var{pred}, or @code{equal?} if not\n"
 416             "given.  An equality call is made just once for each element,\n"
 417             "but the order in which the calls are made on the elements is\n"
 418             "unspecified.\n"
 419             "\n"
 420             "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
 421             "given @var{x} is first.  This means for instance elements\n"
 422             "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
 423             "\n"
 424             "@var{lst} is not modified, but the returned list might share a\n"
 425             "common tail with @var{lst}.")
 426 #define FUNC_NAME s_scm_srfi1_delete
 427 {
 428   scm_t_trampoline_2 equal_p;
 429   SCM  ret, *p, keeplst;
 430   int  count;
 431
 432   if (SCM_UNBNDP (pred))
 433     return scm_delete (x, lst);
 434
 435   equal_p = scm_trampoline_2 (pred);
 436   SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME);
 437
 438   /* ret is the return list being constructed.  p is where to append to it,
 439      initially &ret then SCM_CDRLOC of the last pair.  lst progresses as
 440      elements are considered.
 441
 442      Elements to be retained are not immediately copied, instead keeplst is
 443      the last pair in lst which is to be retained but not yet copied, count
 444      is how many from there are wanted.  When there's no more deletions, *p
 445      can be set to keeplst to share the remainder of the original lst.  (The
 446      entire original lst if there's no deletions at all.)  */
 447
 448   keeplst = lst;
 449   count = 0;
 450   p = &ret;
 451
 452   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
 453     {
 454       if (scm_is_true (equal_p (pred, x, SCM_CAR (lst))))
 455         {
 456           /* delete this element, so copy those at keeplst */
 457           p = list_copy_part (keeplst, count, p);
 458           keeplst = SCM_CDR (lst);
 459           count = 0;
 460         }
 461       else
 462         {
 463           /* keep this element */
 464           count++;
 465         }
 466     }
 467
 468   /* final retained elements */
 469   *p = keeplst;
 470
 471   /* demand that lst was a proper list */
 472   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
 473
 474   return ret;
 475 }
 476 #undef FUNC_NAME
 477
 478
 479 SCM_DEFINE (scm_srfi1_delete_x, "delete!", 2, 1, 0,
 480             (SCM x, SCM lst, SCM pred),
 481             "Return a list containing the elements of @var{lst} but with\n"
 482             "those equal to @var{x} deleted.  The returned elements will be\n"
 483             "in the same order as they were in @var{lst}.\n"
 484             "\n"
 485             "Equality is determined by @var{pred}, or @code{equal?} if not\n"
 486             "given.  An equality call is made just once for each element,\n"
 487             "but the order in which the calls are made on the elements is\n"
 488             "unspecified.\n"
 489             "\n"
 490             "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
 491             "given @var{x} is first.  This means for instance elements\n"
 492             "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
 493             "\n"
 494             "@var{lst} may be modified to construct the returned list.")
 495 #define FUNC_NAME s_scm_srfi1_delete_x
 496 {
 497   scm_t_trampoline_2 equal_p;
 498   SCM walk;
 499   SCM *prev;
 500
 501   if (SCM_UNBNDP (pred))
 502     return scm_delete_x (x, lst);
 503
 504   equal_p = scm_trampoline_2 (pred);
 505   SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME);
 506
 507   for (prev = &lst, walk = lst;
 508        scm_is_pair (walk);
 509        walk = SCM_CDR (walk))
 510     {
 511       if (scm_is_true (equal_p (pred, x, SCM_CAR (walk))))
 512         *prev = SCM_CDR (walk);
 513       else
 514         prev = SCM_CDRLOC (walk);
 515     }
 516
 517   /* demand the input was a proper list */
 518   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk), walk, SCM_ARG2, FUNC_NAME,"list");
 519   return lst;
 520 }
 521 #undef FUNC_NAME
 522
 523
 524 SCM_DEFINE (scm_srfi1_delete_duplicates, "delete-duplicates", 1, 1, 0,
 525             (SCM lst, SCM pred),
 526             "Return a list containing the elements of @var{lst} but without\n"
 527             "duplicates.\n"
 528             "\n"
 529             "When elements are equal, only the first in @var{lst} is\n"
 530             "retained.  Equal elements can be anywhere in @var{lst}, they\n"
 531             "don't have to be adjacent.  The returned list will have the\n"
 532             "retained elements in the same order as they were in @var{lst}.\n"
 533             "\n"
 534             "Equality is determined by @var{pred}, or @code{equal?} if not\n"
 535             "given.  Calls @code{(pred x y)} are made with element @var{x}\n"
 536             "being before @var{y} in @var{lst}.  A call is made at most once\n"
 537             "for each combination, but the sequence of the calls across the\n"
 538             "elements is unspecified.\n"
 539             "\n"
 540             "@var{lst} is not modified, but the return might share a common\n"
 541             "tail with @var{lst}.\n"
 542             "\n"
 543             "In the worst case, this is an @math{O(N^2)} algorithm because\n"
 544             "it must check each element against all those preceding it.  For\n"
 545             "long lists it is more efficient to sort and then compare only\n"
 546             "adjacent elements.")
 547 #define FUNC_NAME s_scm_srfi1_delete_duplicates
 548 {
 549   scm_t_trampoline_2 equal_p;
 550   SCM  ret, *p, keeplst, item, l;
 551   int  count, i;
 552
 553   /* ret is the new list constructed.  p is where to append, initially &ret
 554      then SCM_CDRLOC of the last pair.  lst is advanced as each element is
 555      considered.
 556
 557      Elements retained are not immediately appended to ret, instead keeplst
 558      is the last pair in lst which is to be kept but is not yet copied.
 559      Initially this is the first pair of lst, since the first element is
 560      always retained.
 561
 562      *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
 563      the elements retained, making the equality search loop easy.
 564
 565      If an item must be deleted, elements from keeplst (inclusive) to lst
 566      (exclusive) must be copied and appended to ret.  When there's no more
 567      deletions, *p is left set to keeplst, so ret shares structure with the
 568      original lst.  (ret will be the entire original lst if there are no
 569      deletions.)  */
 570
 571   /* skip to end if an empty list (or something invalid) */
 572   ret = SCM_EOL;
 573
 574   if (SCM_UNBNDP (pred))
 575     equal_p = equal_trampoline;
 576   else
 577     {
 578       equal_p = scm_trampoline_2 (pred);
 579       SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME);
 580     }
 581
 582   keeplst = lst;
 583   count = 0;
 584   p = &ret;
 585
 586   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
 587     {
 588       item = SCM_CAR (lst);
 589
 590       /* look for item in "ret" list */
 591       for (l = ret; scm_is_pair (l); l = SCM_CDR (l))
 592         {
 593           if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
 594             {
 595               /* "item" is a duplicate, so copy keeplst onto ret */
 596             duplicate:
 597               p = list_copy_part (keeplst, count, p);
 598
 599               keeplst = SCM_CDR (lst);  /* elem after the one deleted */
 600               count = 0;
 601               goto next_elem;
 602             }
 603         }
 604
 605       /* look for item in "keeplst" list
 606          be careful traversing, in case nasty code changed the cdrs */
 607       for (i = 0,       l = keeplst;
 608            i < count && scm_is_pair (l);
 609            i++,         l = SCM_CDR (l))
 610         if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
 611           goto duplicate;
 612
 613       /* keep this element */
 614       count++;
 615
 616     next_elem:
 617       ;
 618     }
 619   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list");
 620
 621   /* share tail of keeplst items */
 622   *p = keeplst;
 623
 624   return ret;
 625 }
 626 #undef FUNC_NAME
 627
 628
 629 SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0,
 630             (SCM lst, SCM pred),
 631             "Return a list containing the elements of @var{lst} but without\n"
 632             "duplicates.\n"
 633             "\n"
 634             "When elements are equal, only the first in @var{lst} is\n"
 635             "retained.  Equal elements can be anywhere in @var{lst}, they\n"
 636             "don't have to be adjacent.  The returned list will have the\n"
 637             "retained elements in the same order as they were in @var{lst}.\n"
 638             "\n"
 639             "Equality is determined by @var{pred}, or @code{equal?} if not\n"
 640             "given.  Calls @code{(pred x y)} are made with element @var{x}\n"
 641             "being before @var{y} in @var{lst}.  A call is made at most once\n"
 642             "for each combination, but the sequence of the calls across the\n"
 643             "elements is unspecified.\n"
 644             "\n"
 645             "@var{lst} may be modified to construct the returned list.\n"
 646             "\n"
 647             "In the worst case, this is an @math{O(N^2)} algorithm because\n"
 648             "it must check each element against all those preceding it.  For\n"
 649             "long lists it is more efficient to sort and then compare only\n"
 650             "adjacent elements.")
 651 #define FUNC_NAME s_scm_srfi1_delete_duplicates_x
 652 {
 653   scm_t_trampoline_2 equal_p;
 654   SCM  ret, endret, item, l;
 655
 656   /* ret is the return list, constructed from the pairs in lst.  endret is
 657      the last pair of ret, initially the first pair.  lst is advanced as
 658      elements are considered.  */
 659
 660   /* skip to end if an empty list (or something invalid) */
 661   ret = lst;
 662   if (scm_is_pair (lst))
 663     {
 664       if (SCM_UNBNDP (pred))
 665         equal_p = equal_trampoline;
 666       else
 667         {
 668           equal_p = scm_trampoline_2 (pred);
 669           SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME);
 670         }
 671
 672       endret = ret;
 673
 674       /* loop over lst elements starting from second */
 675       for (;;)
 676         {
 677           lst = SCM_CDR (lst);
 678           if (! scm_is_pair (lst))
 679             break;
 680           item = SCM_CAR (lst);
 681
 682           /* is item equal to any element from ret to endret (inclusive)? */
 683           l = ret;
 684           for (;;)
 685             {
 686               if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
 687                 break;  /* equal, forget this element */
 688
 689               if (scm_is_eq (l, endret))
 690                 {
 691                   /* not equal to any, so append this pair */
 692                   SCM_SETCDR (endret, lst);
 693                   endret = lst;
 694                   break;
 695                 }
 696               l = SCM_CDR (l);
 697             }
 698         }
 699
 700       /* terminate, in case last element was deleted */
 701       SCM_SETCDR (endret, SCM_EOL);
 702     }
 703
 704   /* demand that lst was a proper list */
 705   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list");
 706
 707   return ret;
 708 }
 709 #undef FUNC_NAME
 710
 711
 712 SCM_DEFINE (scm_srfi1_drop_right, "drop-right", 2, 0, 0,
 713             (SCM lst, SCM n),
 714             "Return a new list containing all except the last @var{n}\n"
 715             "elements of @var{lst}.")
 716 #define FUNC_NAME s_scm_srfi1_drop_right
 717 {
 718   SCM tail = scm_list_tail (lst, n);
 719   SCM ret = SCM_EOL;
 720   SCM *rend = &ret;
 721   while (scm_is_pair (tail))
 722     {
 723       *rend = scm_cons (SCM_CAR (lst), SCM_EOL);
 724       rend = SCM_CDRLOC (*rend);
 725
 726       lst = SCM_CDR (lst);
 727       tail = SCM_CDR (tail);
 728     }
 729   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
 730   return ret;
 731 }
 732 #undef FUNC_NAME
 733
 734
 735 SCM_DEFINE (scm_srfi1_drop_right_x, "drop-right!", 2, 0, 0,
 736             (SCM lst, SCM n),
 737             "Return the a list containing the @var{n} last elements of\n"
 738             "@var{lst}.  @var{lst} may be modified to build the return.")
 739 #define FUNC_NAME s_scm_srfi1_drop_right_x
 740 {
 741   SCM tail, *p;
 742
 743   if (scm_is_eq (n, SCM_INUM0))
 744     return lst;
 745
 746   tail = scm_list_tail (lst, n);
 747   p = &lst;
 748
 749   /* p and tail work along the list, p being the cdrloc of the cell n steps
 750      behind tail */
 751   for ( ; scm_is_pair (tail); tail = SCM_CDR (tail))
 752     p = SCM_CDRLOC (*p);
 753
 754   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
 755
 756   *p = SCM_EOL;
 757   return lst;
 758 }
 759 #undef FUNC_NAME
 760
 761
 762 SCM_DEFINE (scm_srfi1_drop_while, "drop-while", 2, 0, 0,
 763             (SCM pred, SCM lst),
 764             "Drop the longest initial prefix of @var{lst} whose elements all\n"
 765             "satisfy the predicate @var{pred}.")
 766 #define FUNC_NAME s_scm_srfi1_drop_while
 767 {
 768   scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
 769   SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
 770
 771   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
 772     if (scm_is_false (pred_tramp (pred, SCM_CAR (lst))))
 773       goto done;
 774
 775   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
 776  done:
 777   return lst;
 778 }
 779 #undef FUNC_NAME
 780
 781
 782 SCM_DEFINE (scm_srfi1_eighth, "eighth", 1, 0, 0,
 783             (SCM lst),
 784             "Return the eighth element of @var{lst}.")
 785 #define FUNC_NAME s_scm_srfi1_eighth
 786 {
 787   return scm_list_ref (lst, SCM_I_MAKINUM (7));
 788 }
 789 #undef FUNC_NAME
 790
 791
 792 SCM_DEFINE (scm_srfi1_fifth, "fifth", 1, 0, 0,
 793             (SCM lst),
 794             "Return the fifth element of @var{lst}.")
 795 #define FUNC_NAME s_scm_srfi1_fifth
 796 {
 797   return scm_list_ref (lst, SCM_I_MAKINUM (4));
 798 }
 799 #undef FUNC_NAME
 800
 801
 802 SCM_DEFINE (scm_srfi1_filter_map, "filter-map", 2, 0, 1,
 803             (SCM proc, SCM list1, SCM rest),
 804             "Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
 805             "return a list of the results as per SRFI-1 @code{map}, except\n"
 806             "that any @code{#f} results are omitted from the list returned.")
 807 #define FUNC_NAME s_scm_srfi1_filter_map
 808 {
 809   SCM  ret, *loc, elem, newcell, lst;
 810   int  argnum;
 811
 812   SCM_VALIDATE_REST_ARGUMENT (rest);
 813
 814   ret = SCM_EOL;
 815   loc = &ret;
 816
 817   if (scm_is_null (rest))
 818     {
 819       /* one list */
 820       scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
 821       SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
 822
 823       for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
 824         {
 825           elem = proc_tramp (proc, SCM_CAR (list1));
 826           if (scm_is_true (elem))
 827             {
 828               newcell = scm_cons (elem, SCM_EOL);
 829               *loc = newcell;
 830               loc = SCM_CDRLOC (newcell);
 831             }
 832         }
 833
 834       /* check below that list1 is a proper list, and done */
 835     end_list1:
 836       lst = list1;
 837       argnum = 2;
 838     }
 839   else if (scm_is_null (SCM_CDR (rest)))
 840     {
 841       /* two lists */
 842       scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
 843       SCM list2 = SCM_CAR (rest);
 844       SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
 845
 846       for (;;)
 847         {
 848           if (! scm_is_pair (list1))
 849             goto end_list1;
 850           if (! scm_is_pair (list2))
 851             {
 852               lst = list2;
 853               argnum = 3;
 854               goto check_lst_and_done;
 855             }
 856           elem = proc_tramp (proc, SCM_CAR (list1), SCM_CAR (list2));
 857           if (scm_is_true (elem))
 858             {
 859               newcell = scm_cons (elem, SCM_EOL);
 860               *loc = newcell;
 861               loc = SCM_CDRLOC (newcell);
 862             }
 863           list1 = SCM_CDR (list1);
 864           list2 = SCM_CDR (list2);
 865         }
 866     }
 867   else
 868     {
 869       /* three or more lists */
 870       SCM  vec, args, a;
 871       size_t len, i;
 872
 873       /* vec is the list arguments */
 874       vec = scm_vector (scm_cons (list1, rest));
 875       len = SCM_SIMPLE_VECTOR_LENGTH (vec);
 876
 877       /* args is the argument list to pass to proc, same length as vec,
 878          re-used for each call */
 879       args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
 880
 881       for (;;)
 882         {
 883           /* first elem of each list in vec into args, and step those
 884              vec entries onto their next element */
 885           for (i = 0, a = args, argnum = 2;
 886                i < len;
 887                i++, a = SCM_CDR (a), argnum++)
 888             {
 889               lst = SCM_SIMPLE_VECTOR_REF (vec, i);  /* list argument */
 890               if (! scm_is_pair (lst))
 891                 goto check_lst_and_done;
 892               SCM_SETCAR (a, SCM_CAR (lst));  /* arg for proc */
 893               SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst));  /* rest of lst */
 894             }
 895
 896           elem = scm_apply (proc, args, SCM_EOL);
 897           if (scm_is_true (elem))
 898             {
 899               newcell = scm_cons (elem, SCM_EOL);
 900               *loc = newcell;
 901               loc = SCM_CDRLOC (newcell);
 902             }
 903         }
 904     }
 905
 906  check_lst_and_done:
 907   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
 908   return ret;
 909 }
 910 #undef FUNC_NAME
 911
 912
 913 SCM_DEFINE (scm_srfi1_find, "find", 2, 0, 0,
 914             (SCM pred, SCM lst),
 915             "Return the first element of @var{lst} which satisfies the\n"
 916             "predicate @var{pred}, or return @code{#f} if no such element is\n"
 917             "found.")
 918 #define FUNC_NAME s_scm_srfi1_find
 919 {
 920   scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
 921   SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
 922
 923   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
 924     {
 925       SCM elem = SCM_CAR (lst);
 926       if (scm_is_true (pred_tramp (pred, elem)))
 927         return elem;
 928     }
 929   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
 930
 931   return SCM_BOOL_F;
 932 }
 933 #undef FUNC_NAME
 934
 935
 936 SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0,
 937             (SCM pred, SCM lst),
 938             "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
 939             "predicate @var{pred}, or return @code{#f} if no such element is\n"
 940             "found.")
 941 #define FUNC_NAME s_scm_srfi1_find_tail
 942 {
 943   scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
 944   SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
 945
 946   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
 947     if (scm_is_true (pred_tramp (pred, SCM_CAR (lst))))
 948       return lst;
 949   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
 950
 951   return SCM_BOOL_F;
 952 }
 953 #undef FUNC_NAME
 954
 955
 956 SCM_DEFINE (scm_srfi1_fold, "fold", 3, 0, 1,
 957             (SCM proc, SCM init, SCM list1, SCM rest),
 958             "Apply @var{proc} to the elements of @var{lst1} @dots{}\n"
 959             "@var{lstN} to build a result, and return that result.\n"
 960             "\n"
 961             "Each @var{proc} call is @code{(@var{proc} @var{elem1} @dots{}\n"
 962             "@var{elemN} @var{previous})}, where @var{elem1} is from\n"
 963             "@var{lst1}, through @var{elemN} from @var{lstN}.\n"
 964             "@var{previous} is the return from the previous call to\n"
 965             "@var{proc}, or the given @var{init} for the first call.  If any\n"
 966             "list is empty, just @var{init} is returned.\n"
 967             "\n"
 968             "@code{fold} works through the list elements from first to last.\n"
 969             "The following shows a list reversal and the calls it makes,\n"
 970             "\n"
 971             "@example\n"
 972             "(fold cons '() '(1 2 3))\n"
 973             "\n"
 974             "(cons 1 '())\n"
 975             "(cons 2 '(1))\n"
 976             "(cons 3 '(2 1)\n"
 977             "@result{} (3 2 1)\n"
 978             "@end example\n"
 979             "\n"
 980             "If @var{lst1} through @var{lstN} have different lengths,\n"
 981             "@code{fold} stops when the end of the shortest is reached.\n"
 982             "Ie.@: elements past the length of the shortest are ignored in\n"
 983             "the other @var{lst}s.  At least one @var{lst} must be\n"
 984             "non-circular.\n"
 985             "\n"
 986             "The way @code{fold} builds a result from iterating is quite\n"
 987             "general, it can do more than other iterations like say\n"
 988             "@code{map} or @code{filter}.  The following for example removes\n"
 989             "adjacent duplicate elements from a list,\n"
 990             "\n"
 991             "@example\n"
 992             "(define (delete-adjacent-duplicates lst)\n"
 993             "  (fold-right (lambda (elem ret)\n"
 994             "                (if (equal? elem (first ret))\n"
 995             "                    ret\n"
 996             "                    (cons elem ret)))\n"
 997             "              (list (last lst))\n"
 998             "              lst))\n"
 999             "(delete-adjacent-duplicates '(1 2 3 3 4 4 4 5))\n"
1000             "@result{} (1 2 3 4 5)\n"
1001             "@end example\n"
1002             "\n"
1003             "Clearly the same sort of thing can be done with a\n"
1004             "@code{for-each} and a variable in which to build the result,\n"
1005             "but a self-contained @var{proc} can be re-used in multiple\n"
1006             "contexts, where a @code{for-each} would have to be written out\n"
1007             "each time.")
1008 #define FUNC_NAME s_scm_srfi1_fold
1009 {
1010   SCM lst;
1011   int argnum;
1012   SCM_VALIDATE_REST_ARGUMENT (rest);
1013
1014   if (scm_is_null (rest))
1015     {
1016       /* one list */
1017       scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
1018       SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
1019
1020       for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
1021         init = proc_tramp (proc, SCM_CAR (list1), init);
1022
1023       /* check below that list1 is a proper list, and done */
1024       lst = list1;
1025       argnum = 2;
1026     }
1027   else
1028     {
1029       /* two or more lists */
1030       SCM  vec, args, a;
1031       size_t  len, i;
1032
1033       /* vec is the list arguments */
1034       vec = scm_vector (scm_cons (list1, rest));
1035       len = SCM_SIMPLE_VECTOR_LENGTH (vec);
1036
1037       /* args is the argument list to pass to proc, same length as vec,
1038          re-used for each call */
1039       args = scm_make_list (SCM_I_MAKINUM (len+1), SCM_UNDEFINED);
1040
1041       for (;;)
1042         {
1043           /* first elem of each list in vec into args, and step those
1044              vec entries onto their next element */
1045           for (i = 0, a = args, argnum = 2;
1046                i < len;
1047                i++, a = SCM_CDR (a), argnum++)
1048             {
1049               lst = SCM_SIMPLE_VECTOR_REF (vec, i);  /* list argument */
1050               if (! scm_is_pair (lst))
1051                 goto check_lst_and_done;
1052               SCM_SETCAR (a, SCM_CAR (lst));  /* arg for proc */
1053               SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst));  /* rest of lst */
1054             }
1055           SCM_SETCAR (a, init);
1056
1057           init = scm_apply (proc, args, SCM_EOL);
1058         }
1059     }
1060
1061  check_lst_and_done:
1062   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
1063   return init;
1064 }
1065 #undef FUNC_NAME
1066
1067
1068 SCM_DEFINE (scm_srfi1_last, "last", 1, 0, 0,
1069             (SCM lst),
1070             "Like @code{cons}, but with interchanged arguments.  Useful\n"
1071             "mostly when passed to higher-order procedures.")
1072 #define FUNC_NAME s_scm_srfi1_last
1073 {
1074   SCM pair = scm_last_pair (lst);
1075   /* scm_last_pair returns SCM_EOL for an empty list */
1076   SCM_VALIDATE_CONS (SCM_ARG1, pair);
1077   return SCM_CAR (pair);
1078 }
1079 #undef FUNC_NAME
1080
1081
1082 SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
1083             (SCM lst),
1084             "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
1085             "circular.")
1086 #define FUNC_NAME s_scm_srfi1_length_plus
1087 {
1088   long len = scm_ilength (lst);
1089   return (len >= 0 ? SCM_I_MAKINUM (len) : SCM_BOOL_F);
1090 }
1091 #undef FUNC_NAME
1092
1093
1094 SCM_DEFINE (scm_srfi1_list_index, "list-index", 2, 0, 1,
1095             (SCM pred, SCM list1, SCM rest),
1096             "Return the index of the first set of elements, one from each of\n"
1097             "@var{lst1}@dots{}@var{lstN}, which satisfies @var{pred}.\n"
1098             "\n"
1099             "@var{pred} is called as @code{(@var{pred} elem1 @dots{}\n"
1100             "elemN)}.  Searching stops when the end of the shortest\n"
1101             "@var{lst} is reached.  The return index starts from 0 for the\n"
1102             "first set of elements.  If no set of elements pass then the\n"
1103             "return is @code{#f}.\n"
1104             "\n"
1105             "@example\n"
1106             "(list-index odd? '(2 4 6 9))      @result{} 3\n"
1107             "(list-index = '(1 2 3) '(3 1 2))  @result{} #f\n"
1108             "@end example")
1109 #define FUNC_NAME s_scm_srfi1_list_index
1110 {
1111   long  n = 0;
1112   SCM   lst;
1113   int   argnum;
1114   SCM_VALIDATE_REST_ARGUMENT (rest);
1115
1116   if (scm_is_null (rest))
1117     {
1118       /* one list */
1119       scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
1120       SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
1121
1122       for ( ; scm_is_pair (list1); n++, list1 = SCM_CDR (list1))
1123         if (scm_is_true (pred_tramp (pred, SCM_CAR (list1))))
1124           return SCM_I_MAKINUM (n);
1125
1126       /* not found, check below that list1 is a proper list */
1127     end_list1:
1128       lst = list1;
1129       argnum = 2;
1130     }
1131   else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
1132     {
1133       /* two lists */
1134       SCM list2 = SCM_CAR (rest);
1135       scm_t_trampoline_2 pred_tramp = scm_trampoline_2 (pred);
1136       SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
1137
1138       for ( ; ; n++)
1139         {
1140           if (! scm_is_pair (list1))
1141             goto end_list1;
1142           if (! scm_is_pair (list2))
1143             {
1144               lst = list2;
1145               argnum = 3;
1146               break;
1147             }
1148           if (scm_is_true (pred_tramp (pred,
1149                                        SCM_CAR (list1), SCM_CAR (list2))))
1150             return SCM_I_MAKINUM (n);
1151
1152           list1 = SCM_CDR (list1);
1153           list2 = SCM_CDR (list2);
1154         }
1155     }
1156   else
1157     {
1158       /* three or more lists */
1159       SCM     vec, args, a;
1160       size_t  len, i;
1161
1162       /* vec is the list arguments */
1163       vec = scm_vector (scm_cons (list1, rest));
1164       len = SCM_SIMPLE_VECTOR_LENGTH (vec);
1165
1166       /* args is the argument list to pass to pred, same length as vec,
1167          re-used for each call */
1168       args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
1169
1170       for ( ; ; n++)
1171         {
1172           /* first elem of each list in vec into args, and step those
1173              vec entries onto their next element */
1174           for (i = 0, a = args, argnum = 2;
1175                i < len;
1176                i++, a = SCM_CDR (a), argnum++)
1177             {
1178               lst = SCM_SIMPLE_VECTOR_REF (vec, i);  /* list argument */
1179               if (! scm_is_pair (lst))
1180                 goto not_found_check_lst;
1181               SCM_SETCAR (a, SCM_CAR (lst));  /* arg for pred */
1182               SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst));  /* rest of lst */
1183             }
1184
1185           if (scm_is_true (scm_apply (pred, args, SCM_EOL)))
1186             return SCM_I_MAKINUM (n);
1187         }
1188     }
1189
1190  not_found_check_lst:
1191   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
1192   return SCM_BOOL_F;
1193 }
1194 #undef FUNC_NAME
1195
1196
1197 /* This routine differs from the core list-copy in allowing improper lists.
1198    Maybe the core could allow them similarly.  */
1199
1200 SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0,
1201             (SCM lst),
1202             "Return a copy of the given list @var{lst}.\n"
1203             "\n"
1204             "@var{lst} can be a proper or improper list.  And if @var{lst}\n"
1205             "is not a pair then it's treated as the final tail of an\n"
1206             "improper list and simply returned.")
1207 #define FUNC_NAME s_scm_srfi1_list_copy
1208 {
1209   SCM newlst;
1210   SCM * fill_here;
1211   SCM from_here;
1212
1213   newlst = lst;
1214   fill_here = &newlst;
1215   from_here = lst;
1216
1217   while (scm_is_pair (from_here))
1218     {
1219       SCM c;
1220       c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
1221       *fill_here = c;
1222       fill_here = SCM_CDRLOC (c);
1223       from_here = SCM_CDR (from_here);
1224     }
1225   return newlst;
1226 }
1227 #undef FUNC_NAME
1228
1229
1230 SCM_DEFINE (scm_srfi1_list_tabulate, "list-tabulate", 2, 0, 0,
1231             (SCM n, SCM proc),
1232             "Return an @var{n}-element list, where each list element is\n"
1233             "produced by applying the procedure @var{init-proc} to the\n"
1234             "corresponding list index.  The order in which @var{init-proc}\n"
1235             "is applied to the indices is not specified.")
1236 #define FUNC_NAME s_scm_srfi1_list_tabulate
1237 {
1238   long i, nn;
1239   scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
1240   SCM ret = SCM_EOL;
1241
1242   nn = scm_to_signed_integer (n, 0, LONG_MAX);
1243   SCM_ASSERT (proc_tramp, proc, SCM_ARG2, FUNC_NAME);
1244
1245   for (i = nn-1; i >= 0; i--)
1246     ret = scm_cons (proc_tramp (proc, scm_from_long (i)), ret);
1247
1248   return ret;
1249 }
1250 #undef FUNC_NAME
1251
1252
1253 SCM_DEFINE (scm_srfi1_lset_adjoin, "lset-adjoin", 2, 0, 1,
1254             (SCM equal, SCM lst, SCM rest),
1255             "Add to @var{list} any of the given @var{elem}s not already in\n"
1256             "the list.  @var{elem}s are @code{cons}ed onto the start of\n"
1257             "@var{list} (so the return shares a common tail with\n"
1258             "@var{list}), but the order they're added is unspecified.\n"
1259             "\n"
1260             "The given @var{=} procedure is used for comparing elements,\n"
1261             "called as @code{(@var{=} listelem elem)}, ie.@: the second\n"
1262             "argument is one of the given @var{elem} parameters.\n"
1263             "\n"
1264             "@example\n"
1265             "(lset-adjoin eqv? '(1 2 3) 4 1 5) @result{} (5 4 1 2 3)\n"
1266             "@end example")
1267 #define FUNC_NAME s_scm_srfi1_lset_adjoin
1268 {
1269   scm_t_trampoline_2 equal_tramp;
1270   SCM l, elem;
1271
1272   equal_tramp = scm_trampoline_2 (equal);
1273   SCM_ASSERT (equal_tramp, equal, SCM_ARG1, FUNC_NAME);
1274   SCM_VALIDATE_REST_ARGUMENT (rest);
1275
1276   /* It's not clear if duplicates among the `rest' elements are meant to be
1277      cast out.  The spec says `=' is called as (= list-elem rest-elem),
1278      suggesting perhaps not, but the reference implementation shows the
1279      "list" at each stage as including those "rest" elements already added.
1280      The latter corresponds to what's described for lset-union, so that's
1281      what's done here.  */
1282
1283   for ( ; scm_is_pair (rest); rest = SCM_CDR (rest))
1284     {
1285       elem = SCM_CAR (rest);
1286
1287       for (l = lst; scm_is_pair (l); l = SCM_CDR (l))
1288         if (scm_is_true (equal_tramp (equal, SCM_CAR (l), elem)))
1289           goto next_elem; /* elem already in lst, don't add */
1290
1291       SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(l), lst, SCM_ARG2, FUNC_NAME, "list");
1292
1293       /* elem is not equal to anything already in lst, add it */
1294       lst = scm_cons (elem, lst);
1295
1296     next_elem:
1297       ;
1298     }
1299
1300   return lst;
1301 }
1302 #undef FUNC_NAME
1303
1304
1305 SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1,
1306             (SCM equal, SCM lst, SCM rest),
1307             "Return @var{lst} with any elements in the lists in @var{rest}\n"
1308             "removed (ie.@: subtracted).  For only one @var{lst} argument,\n"
1309             "just that list is returned.\n"
1310             "\n"
1311             "The given @var{equal} procedure is used for comparing elements,\n"
1312             "called as @code{(@var{equal} elem1 elemN)}.  The first argument\n"
1313             "is from @var{lst} and the second from one of the subsequent\n"
1314             "lists.  But exactly which calls are made and in what order is\n"
1315             "unspecified.\n"
1316             "\n"
1317             "@example\n"
1318             "(lset-difference! eqv? (list 'x 'y))           @result{} (x y)\n"
1319             "(lset-difference! eqv? (list 1 2 3) '(3 1))    @result{} (2)\n"
1320             "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n"
1321             "@end example\n"
1322             "\n"
1323             "@code{lset-difference!} may modify @var{lst} to form its\n"
1324             "result.")
1325 #define FUNC_NAME s_scm_srfi1_lset_difference_x
1326 {
1327   scm_t_trampoline_2 equal_tramp = scm_trampoline_2 (equal);
1328   SCM ret, *pos, elem, r, b;
1329   int argnum;
1330
1331   SCM_ASSERT (equal_tramp, equal, SCM_ARG1, FUNC_NAME);
1332   SCM_VALIDATE_REST_ARGUMENT (rest);
1333
1334   ret = SCM_EOL;
1335   pos = &ret;
1336   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
1337     {
1338       elem = SCM_CAR (lst);
1339
1340       for (r = rest, argnum = SCM_ARG3;
1341            scm_is_pair (r);
1342            r = SCM_CDR (r), argnum++)
1343         {
1344           for (b = SCM_CAR (r); scm_is_pair (b); b = SCM_CDR (b))
1345             if (scm_is_true (equal_tramp (equal, elem, SCM_CAR (b))))
1346               goto next_elem; /* equal to elem, so drop that elem */
1347
1348           SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b), b, argnum, FUNC_NAME,"list");
1349         }
1350
1351       /* elem not equal to anything in later lists, so keep it */
1352       *pos = lst;
1353       pos = SCM_CDRLOC (lst);
1354
1355     next_elem:
1356       ;
1357     }
1358   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
1359
1360   *pos = SCM_EOL;
1361   return ret;
1362 }
1363 #undef FUNC_NAME
1364
1365
1366 /* Typechecking for multi-argument MAP and FOR-EACH.
1367
1368    Verify that each element of the vector ARGV, except for the first,
1369    is a list and return minimum length.  Attribute errors to WHO,
1370    and claim that the i'th element of ARGV is WHO's i+2'th argument.  */
1371 static inline int
1372 check_map_args (SCM argv,
1373                 long len,
1374                 SCM gf,
1375                 SCM proc,
1376                 SCM args,
1377                 const char *who)
1378 {
1379   long i;
1380   SCM elt;
1381
1382   for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
1383     {
1384       long elt_len;
1385       elt = SCM_SIMPLE_VECTOR_REF (argv, i);
1386
1387       if (!(scm_is_null (elt) || scm_is_pair (elt)))
1388         goto check_map_error;
1389
1390       elt_len = srfi1_ilength (elt);
1391       if (elt_len < -1)
1392         goto check_map_error;
1393
1394       if (len < 0 || (elt_len >= 0 && elt_len < len))
1395         len = elt_len;
1396     }
1397
1398   if (len < 0)
1399     {
1400       /* i == 0 */
1401       elt = SCM_EOL;
1402     check_map_error:
1403       if (gf)
1404         scm_apply_generic (gf, scm_cons (proc, args));
1405       else
1406         scm_wrong_type_arg (who, i + 2, elt);
1407     }
1408
1409   scm_remember_upto_here_1 (argv);
1410   return len;
1411 }
1412
1413
1414 SCM_GPROC (s_srfi1_map, "map", 2, 0, 1, scm_srfi1_map, g_srfi1_map);
1415
1416 /* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
1417    sequentially, starting with the first element(s).  This is used in
1418    the Scheme procedure `map-in-order', which guarantees sequential
1419    behaviour, is implemented using scm_map.  If the behaviour changes,
1420    we need to update `map-in-order'.
1421 */
1422
1423 SCM
1424 scm_srfi1_map (SCM proc, SCM arg1, SCM args)
1425 #define FUNC_NAME s_srfi1_map
1426 {
1427   long i, len;
1428   SCM res = SCM_EOL;
1429   SCM *pres = &res;
1430
1431   len = srfi1_ilength (arg1);
1432   SCM_GASSERTn ((scm_is_null (arg1) || scm_is_pair (arg1)) && len >= -1,
1433                 g_srfi1_map,
1434                 scm_cons2 (proc, arg1, args), SCM_ARG2, s_srfi1_map);
1435   SCM_VALIDATE_REST_ARGUMENT (args);
1436   if (scm_is_null (args))
1437     {
1438       scm_t_trampoline_1 call = scm_trampoline_1 (proc);
1439       SCM_GASSERT2 (call, g_srfi1_map, proc, arg1, SCM_ARG1, s_srfi1_map);
1440       SCM_GASSERT2 (len >= 0, g_srfi1_map, proc, arg1, SCM_ARG2, s_srfi1_map);
1441       while (SCM_NIMP (arg1))
1442         {
1443           *pres = scm_list_1 (call (proc, SCM_CAR (arg1)));
1444           pres = SCM_CDRLOC (*pres);
1445           arg1 = SCM_CDR (arg1);
1446         }
1447       return res;
1448     }
1449   if (scm_is_null (SCM_CDR (args)))
1450     {
1451       SCM arg2 = SCM_CAR (args);
1452       int len2 = srfi1_ilength (arg2);
1453       scm_t_trampoline_2 call = scm_trampoline_2 (proc);
1454       SCM_GASSERTn (call, g_srfi1_map,
1455                     scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_map);
1456       if (len < 0 || (len2 >= 0 && len2 < len))
1457         len = len2;
1458       SCM_GASSERTn ((scm_is_null (arg2) || scm_is_pair (arg2))
1459                     && len >= 0 && len2 >= -1,
1460                     g_srfi1_map,
1461                     scm_cons2 (proc, arg1, args),
1462                     len2 >= 0 ? SCM_ARG2 : SCM_ARG3,
1463                     s_srfi1_map);
1464       while (len > 0)
1465         {
1466           *pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
1467           pres = SCM_CDRLOC (*pres);
1468           arg1 = SCM_CDR (arg1);
1469           arg2 = SCM_CDR (arg2);
1470           --len;
1471         }
1472       return res;
1473     }
1474   args = scm_vector (arg1 = scm_cons (arg1, args));
1475   len = check_map_args (args, len, g_srfi1_map, proc, arg1, s_srfi1_map);
1476   while (len > 0)
1477     {
1478       arg1 = SCM_EOL;
1479       for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
1480         {
1481           SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
1482           arg1 = scm_cons (SCM_CAR (elt), arg1);
1483           SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
1484         }
1485       *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
1486       pres = SCM_CDRLOC (*pres);
1487       --len;
1488     }
1489   return res;
1490 }
1491 #undef FUNC_NAME
1492
1493 SCM_REGISTER_PROC (s_srfi1_map_in_order, "map-in-order", 2, 0, 1, scm_srfi1_map);
1494
1495 SCM_GPROC (s_srfi1_for_each, "for-each", 2, 0, 1, scm_srfi1_for_each, g_srfi1_for_each);
1496
1497 SCM
1498 scm_srfi1_for_each (SCM proc, SCM arg1, SCM args)
1499 #define FUNC_NAME s_srfi1_for_each
1500 {
1501   long i, len;
1502   len = srfi1_ilength (arg1);
1503   SCM_GASSERTn ((scm_is_null (arg1) || scm_is_pair (arg1)) && len >= -1,
1504                 g_srfi1_for_each, scm_cons2 (proc, arg1, args),
1505                 SCM_ARG2, s_srfi1_for_each);
1506   SCM_VALIDATE_REST_ARGUMENT (args);
1507   if (scm_is_null (args))
1508     {
1509       scm_t_trampoline_1 call = scm_trampoline_1 (proc);
1510       SCM_GASSERT2 (call, g_srfi1_for_each, proc, arg1,
1511                     SCM_ARG1, s_srfi1_for_each);
1512       SCM_GASSERT2 (len >= 0, g_srfi1_for_each, proc, arg1,
1513                     SCM_ARG2, s_srfi1_map);
1514       while (SCM_NIMP (arg1))
1515         {
1516           call (proc, SCM_CAR (arg1));
1517           arg1 = SCM_CDR (arg1);
1518         }
1519       return SCM_UNSPECIFIED;
1520     }
1521   if (scm_is_null (SCM_CDR (args)))
1522     {
1523       SCM arg2 = SCM_CAR (args);
1524       int len2 = srfi1_ilength (arg2);
1525       scm_t_trampoline_2 call = scm_trampoline_2 (proc);
1526       SCM_GASSERTn (call, g_srfi1_for_each,
1527                     scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_for_each);
1528       if (len < 0 || (len2 >= 0 && len2 < len))
1529         len = len2;
1530       SCM_GASSERTn ((scm_is_null (arg2) || scm_is_pair (arg2))
1531                     && len >= 0 && len2 >= -1,
1532                     g_srfi1_for_each,
1533                     scm_cons2 (proc, arg1, args),
1534                     len2 >= 0 ? SCM_ARG2 : SCM_ARG3,
1535                     s_srfi1_for_each);
1536       while (len > 0)
1537         {
1538           call (proc, SCM_CAR (arg1), SCM_CAR (arg2));
1539           arg1 = SCM_CDR (arg1);
1540           arg2 = SCM_CDR (arg2);
1541           --len;
1542         }
1543       return SCM_UNSPECIFIED;
1544     }
1545   args = scm_vector (arg1 = scm_cons (arg1, args));
1546   len = check_map_args (args, len, g_srfi1_for_each, proc, arg1,
1547                         s_srfi1_for_each);
1548   while (len > 0)
1549     {
1550       arg1 = SCM_EOL;
1551       for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
1552         {
1553           SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
1554           arg1 = scm_cons (SCM_CAR (elt), arg1);
1555           SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
1556         }
1557       scm_apply (proc, arg1, SCM_EOL);
1558       --len;
1559     }
1560   return SCM_UNSPECIFIED;
1561 }
1562 #undef FUNC_NAME
1563
1564
1565 SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0,
1566            (SCM x, SCM lst, SCM pred),
1567             "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
1568             "to @var{x}.  If @var{x} does not appear in @var{lst}, return\n"
1569             "@code{#f}.\n"
1570             "\n"
1571             "Equality is determined by @code{equal?}, or by the equality\n"
1572             "predicate @var{=} if given.  @var{=} is called @code{(= @var{x}\n"
1573             "elem)}, ie.@: with the given @var{x} first, so for example to\n"
1574             "find the first element greater than 5,\n"
1575             "\n"
1576             "@example\n"
1577             "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
1578             "@end example\n"
1579             "\n"
1580             "This version of @code{member} extends the core @code{member} by\n"
1581             "accepting an equality predicate.")
1582 #define FUNC_NAME s_scm_srfi1_member
1583 {
1584   scm_t_trampoline_2 equal_p;
1585   SCM_VALIDATE_LIST (2, lst);
1586   if (SCM_UNBNDP (pred))
1587     equal_p = equal_trampoline;
1588   else
1589     {
1590       equal_p = scm_trampoline_2 (pred);
1591       SCM_ASSERT (equal_p, pred, 3, FUNC_NAME);
1592     }
1593   for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
1594     {
1595       if (scm_is_true (equal_p (pred, x, SCM_CAR (lst))))
1596         return lst;
1597     }
1598   return SCM_BOOL_F;
1599 }
1600 #undef FUNC_NAME
1601
1602 SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
1603             (SCM key, SCM alist, SCM pred),
1604             "Behaves like @code{assq} but uses third argument @var{pred?}\n"
1605             "for key comparison.  If @var{pred?} is not supplied,\n"
1606             "@code{equal?} is used.  (Extended from R5RS.)\n")
1607 #define FUNC_NAME s_scm_srfi1_assoc
1608 {
1609   SCM ls = alist;
1610   scm_t_trampoline_2 equal_p;
1611   if (SCM_UNBNDP (pred))
1612     equal_p = equal_trampoline;
1613   else
1614     {
1615       equal_p = scm_trampoline_2 (pred);
1616       SCM_ASSERT (equal_p, pred, 3, FUNC_NAME);
1617     }
1618   for(; scm_is_pair (ls); ls = SCM_CDR (ls))
1619     {
1620       SCM tmp = SCM_CAR (ls);
1621       SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
1622                        "association list");
1623       if (scm_is_true (equal_p (pred, key, SCM_CAR (tmp))))
1624         return tmp;
1625     }
1626   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
1627                    "association list");
1628   return SCM_BOOL_F;
1629 }
1630 #undef FUNC_NAME
1631
1632
1633 SCM_DEFINE (scm_srfi1_ninth, "ninth", 1, 0, 0,
1634             (SCM lst),
1635             "Return the ninth element of @var{lst}.")
1636 #define FUNC_NAME s_scm_srfi1_ninth
1637 {
1638   return scm_list_ref (lst, scm_from_int (8));
1639 }
1640 #undef FUNC_NAME
1641
1642
1643 SCM_DEFINE (scm_srfi1_not_pair_p, "not-pair?", 1, 0, 0,
1644             (SCM obj),
1645             "Return @code{#t} is @var{obj} is not a pair, @code{#f}\n"
1646             "otherwise.\n"
1647             "\n"
1648             "This is shorthand notation @code{(not (pair?  @var{obj}))} and\n"
1649             "is supposed to be used for end-of-list checking in contexts\n"
1650             "where dotted lists are allowed.")
1651 #define FUNC_NAME s_scm_srfi1_not_pair_p
1652 {
1653   return scm_from_bool (! scm_is_pair (obj));
1654 }
1655 #undef FUNC_NAME
1656
1657
1658 SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
1659             (SCM pred, SCM list),
1660             "Partition the elements of @var{list} with predicate @var{pred}.\n"
1661             "Return two values: the list of elements satifying @var{pred} and\n"
1662             "the list of elements @emph{not} satisfying @var{pred}.  The order\n"
1663             "of the output lists follows the order of @var{list}.  @var{list}\n"
1664             "is not mutated.  One of the output lists may share memory with @var{list}.\n")
1665 #define FUNC_NAME s_scm_srfi1_partition
1666 {
1667   /* In this implementation, the output lists don't share memory with
1668      list, because it's probably not worth the effort. */
1669   scm_t_trampoline_1 call = scm_trampoline_1(pred);
1670   SCM orig_list = list;
1671   SCM kept = scm_cons(SCM_EOL, SCM_EOL);
1672   SCM kept_tail = kept;
1673   SCM dropped = scm_cons(SCM_EOL, SCM_EOL);
1674   SCM dropped_tail = dropped;
1675
1676   SCM_ASSERT(call, pred, 2, FUNC_NAME);
1677
1678   for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) {
1679     SCM elt, new_tail;
1680
1681     /* Make sure LIST is not a dotted list.  */
1682     SCM_ASSERT (scm_is_pair (list), orig_list, SCM_ARG2, FUNC_NAME);
1683
1684     elt = SCM_CAR (list);
1685     new_tail = scm_cons (SCM_CAR (list), SCM_EOL);
1686
1687     if (scm_is_true (call (pred, elt))) {
1688       SCM_SETCDR(kept_tail, new_tail);
1689       kept_tail = new_tail;
1690     }
1691     else {
1692       SCM_SETCDR(dropped_tail, new_tail);
1693       dropped_tail = new_tail;
1694     }
1695   }
1696   /* re-use the initial conses for the values list */
1697   SCM_SETCAR(kept, SCM_CDR(kept));
1698   SCM_SETCDR(kept, dropped);
1699   SCM_SETCAR(dropped, SCM_CDR(dropped));
1700   SCM_SETCDR(dropped, SCM_EOL);
1701   return scm_values(kept);
1702 }
1703 #undef FUNC_NAME
1704
1705
1706 SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0,
1707             (SCM pred, SCM lst),
1708             "Split @var{lst} into those elements which do and don't satisfy\n"
1709             "the predicate @var{pred}.\n"
1710             "\n"
1711             "The return is two values (@pxref{Multiple Values}), the first\n"
1712             "being a list of all elements from @var{lst} which satisfy\n"
1713             "@var{pred}, the second a list of those which do not.\n"
1714             "\n"
1715             "The elements in the result lists are in the same order as in\n"
1716             "@var{lst} but the order in which the calls @code{(@var{pred}\n"
1717             "elem)} are made on the list elements is unspecified.\n"
1718             "\n"
1719             "@var{lst} may be modified to construct the return lists.")
1720 #define FUNC_NAME s_scm_srfi1_partition_x
1721 {
1722   SCM  tlst, flst, *tp, *fp;
1723   scm_t_trampoline_1 pred_tramp;
1724
1725   pred_tramp = scm_trampoline_1 (pred);
1726   SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
1727
1728   /* tlst and flst are the lists of true and false elements.  tp and fp are
1729      where to store to append to them, initially &tlst and &flst, then
1730      SCM_CDRLOC of the last pair in the respective lists.  */
1731
1732   tlst = SCM_EOL;
1733   flst = SCM_EOL;
1734   tp = &tlst;
1735   fp = &flst;
1736
1737   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
1738     {
1739       if (scm_is_true (pred_tramp (pred, SCM_CAR (lst))))
1740         {
1741           *tp = lst;
1742           tp = SCM_CDRLOC (lst);
1743         }
1744       else
1745         {
1746           *fp = lst;
1747           fp = SCM_CDRLOC (lst);
1748         }
1749     }
1750
1751   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
1752
1753   /* terminate whichever didn't get the last element(s) */
1754   *tp = SCM_EOL;
1755   *fp = SCM_EOL;
1756
1757   return scm_values (scm_list_2 (tlst, flst));
1758 }
1759 #undef FUNC_NAME
1760
1761
1762 SCM_DEFINE (scm_srfi1_reduce, "reduce", 3, 0, 0,
1763             (SCM proc, SCM def, SCM lst),
1764             "@code{reduce} is a variant of @code{fold}, where the first call\n"
1765             "to @var{proc} is on two elements from @var{lst}, rather than\n"
1766             "one element and a given initial value.\n"
1767             "\n"
1768             "If @var{lst} is empty, @code{reduce} returns @var{def} (this is\n"
1769             "the only use for @var{def}).  If @var{lst} has just one element\n"
1770             "then that's the return value.  Otherwise @var{proc} is called\n"
1771             "on the elements of @var{lst}.\n"
1772             "\n"
1773             "Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
1774             "@var{previous})}, where @var{elem} is from @var{lst} (the\n"
1775             "second and subsequent elements of @var{lst}), and\n"
1776             "@var{previous} is the return from the previous call to\n"
1777             "@var{proc}.  The first element of @var{lst} is the\n"
1778             "@var{previous} for the first call to @var{proc}.\n"
1779             "\n"
1780             "For example, the following adds a list of numbers, the calls\n"
1781             "made to @code{+} are shown.  (Of course @code{+} accepts\n"
1782             "multiple arguments and can add a list directly, with\n"
1783             "@code{apply}.)\n"
1784             "\n"
1785             "@example\n"
1786             "(reduce + 0 '(5 6 7)) @result{} 18\n"
1787             "\n"
1788             "(+ 6 5)  @result{} 11\n"
1789             "(+ 7 11) @result{} 18\n"
1790             "@end example\n"
1791             "\n"
1792             "@code{reduce} can be used instead of @code{fold} where the\n"
1793             "@var{init} value is an ``identity'', meaning a value which\n"
1794             "under @var{proc} doesn't change the result, in this case 0 is\n"
1795             "an identity since @code{(+ 5 0)} is just 5.  @code{reduce}\n"
1796             "avoids that unnecessary call.")
1797 #define FUNC_NAME s_scm_srfi1_reduce
1798 {
1799   scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
1800   SCM  ret;
1801
1802   SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
1803
1804   ret = def;  /* if lst is empty */
1805   if (scm_is_pair (lst))
1806     {
1807       ret = SCM_CAR (lst);  /* if lst has one element */
1808
1809       for (lst = SCM_CDR (lst); scm_is_pair (lst); lst = SCM_CDR (lst))
1810         ret = proc_tramp (proc, SCM_CAR (lst), ret);
1811     }
1812
1813   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG3, FUNC_NAME, "list");
1814   return ret;
1815 }
1816 #undef FUNC_NAME
1817
1818
1819 SCM_DEFINE (scm_srfi1_reduce_right, "reduce-right", 3, 0, 0,
1820             (SCM proc, SCM def, SCM lst),
1821             "@code{reduce-right} is a variant of @code{fold-right}, where\n"
1822             "the first call to @var{proc} is on two elements from @var{lst},\n"
1823             "rather than one element and a given initial value.\n"
1824             "\n"
1825             "If @var{lst} is empty, @code{reduce-right} returns @var{def}\n"
1826             "(this is the only use for @var{def}).  If @var{lst} has just\n"
1827             "one element then that's the return value.  Otherwise @var{proc}\n"
1828             "is called on the elements of @var{lst}.\n"
1829             "\n"
1830             "Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
1831             "@var{previous})}, where @var{elem} is from @var{lst} (the\n"
1832             "second last and then working back to the first element of\n"
1833             "@var{lst}), and @var{previous} is the return from the previous\n"
1834             "call to @var{proc}.  The last element of @var{lst} is the\n"
1835             "@var{previous} for the first call to @var{proc}.\n"
1836             "\n"
1837             "For example, the following adds a list of numbers, the calls\n"
1838             "made to @code{+} are shown.  (Of course @code{+} accepts\n"
1839             "multiple arguments and can add a list directly, with\n"
1840             "@code{apply}.)\n"
1841             "\n"
1842             "@example\n"
1843             "(reduce-right + 0 '(5 6 7)) @result{} 18\n"
1844             "\n"
1845             "(+ 6 7)  @result{} 13\n"
1846             "(+ 5 13) @result{} 18\n"
1847             "@end example\n"
1848             "\n"
1849             "@code{reduce-right} can be used instead of @code{fold-right}\n"
1850             "where the @var{init} value is an ``identity'', meaning a value\n"
1851             "which under @var{proc} doesn't change the result, in this case\n"
1852             "0 is an identity since @code{(+ 7 0)} is just 5.\n"
1853             "@code{reduce-right} avoids that unnecessary call.\n"
1854             "\n"
1855             "@code{reduce} should be preferred over @code{reduce-right} if\n"
1856             "the order of processing doesn't matter, or can be arranged\n"
1857             "either way, since @code{reduce} is a little more efficient.")
1858 #define FUNC_NAME s_scm_srfi1_reduce_right
1859 {
1860   /* To work backwards across a list requires either repeatedly traversing
1861      to get each previous element, or using some memory for a reversed or
1862      random-access form.  Repeated traversal might not be too terrible, but
1863      is of course quadratic complexity and hence to be avoided in case LST
1864      is long.  A vector is preferred over a reversed list since it's more
1865      compact and is less work for the gc to collect.  */
1866
1867   scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
1868   SCM  ret, vec;
1869   long len, i;
1870
1871   SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
1872
1873   if (SCM_NULL_OR_NIL_P (lst))
1874     return def;
1875
1876   vec = scm_vector (lst);
1877   len = SCM_SIMPLE_VECTOR_LENGTH (vec);
1878
1879   ret = SCM_SIMPLE_VECTOR_REF (vec, len-1);
1880   for (i = len-2; i >= 0; i--)
1881     ret = proc_tramp (proc, SCM_SIMPLE_VECTOR_REF (vec, i), ret);
1882
1883   return ret;
1884 }
1885 #undef FUNC_NAME
1886
1887
1888 SCM_DEFINE (scm_srfi1_remove, "remove", 2, 0, 0,
1889             (SCM pred, SCM list),
1890             "Return a list containing all elements from @var{lst} which do\n"
1891             "not satisfy the predicate @var{pred}.  The elements in the\n"
1892             "result list have the same order as in @var{lst}.  The order in\n"
1893             "which @var{pred} is applied to the list elements is not\n"
1894             "specified.")
1895 #define FUNC_NAME s_scm_srfi1_remove
1896 {
1897   scm_t_trampoline_1 call = scm_trampoline_1 (pred);
1898   SCM walk;
1899   SCM *prev;
1900   SCM res = SCM_EOL;
1901   SCM_ASSERT (call, pred, 1, FUNC_NAME);
1902   SCM_VALIDATE_LIST (2, list);
1903
1904   for (prev = &res, walk = list;
1905        scm_is_pair (walk);
1906        walk = SCM_CDR (walk))
1907     {
1908       if (scm_is_false (call (pred, SCM_CAR (walk))))
1909         {
1910           *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
1911           prev = SCM_CDRLOC (*prev);
1912         }
1913     }
1914
1915   return res;
1916 }
1917 #undef FUNC_NAME
1918
1919
1920 SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
1921             (SCM pred, SCM list),
1922             "Return a list containing all elements from @var{list} which do\n"
1923             "not satisfy the predicate @var{pred}.  The elements in the\n"
1924             "result list have the same order as in @var{list}.  The order in\n"
1925             "which @var{pred} is applied to the list elements is not\n"
1926             "specified.  @var{list} may be modified to build the return\n"
1927             "list.")
1928 #define FUNC_NAME s_scm_srfi1_remove_x
1929 {
1930   scm_t_trampoline_1 call = scm_trampoline_1 (pred);
1931   SCM walk;
1932   SCM *prev;
1933   SCM_ASSERT (call, pred, 1, FUNC_NAME);
1934   SCM_VALIDATE_LIST (2, list);
1935
1936   for (prev = &list, walk = list;
1937        scm_is_pair (walk);
1938        walk = SCM_CDR (walk))
1939     {
1940       if (scm_is_false (call (pred, SCM_CAR (walk))))
1941         prev = SCM_CDRLOC (walk);
1942       else
1943         *prev = SCM_CDR (walk);
1944     }
1945
1946   return list;
1947 }
1948 #undef FUNC_NAME
1949
1950
1951 SCM_DEFINE (scm_srfi1_seventh, "seventh", 1, 0, 0,
1952             (SCM lst),
1953             "Return the seventh element of @var{lst}.")
1954 #define FUNC_NAME s_scm_srfi1_seventh
1955 {
1956   return scm_list_ref (lst, scm_from_int (6));
1957 }
1958 #undef FUNC_NAME
1959
1960
1961 SCM_DEFINE (scm_srfi1_sixth, "sixth", 1, 0, 0,
1962             (SCM lst),
1963             "Return the sixth element of @var{lst}.")
1964 #define FUNC_NAME s_scm_srfi1_sixth
1965 {
1966   return scm_list_ref (lst, scm_from_int (5));
1967 }
1968 #undef FUNC_NAME
1969
1970
1971 SCM_DEFINE (scm_srfi1_span, "span", 2, 0, 0,
1972             (SCM pred, SCM lst),
1973             "Return two values, the longest initial prefix of @var{lst}\n"
1974             "whose elements all satisfy the predicate @var{pred}, and the\n"
1975             "remainder of @var{lst}.")
1976 #define FUNC_NAME s_scm_srfi1_span
1977 {
1978   scm_t_trampoline_1 pred_tramp;
1979   SCM ret, *p;
1980
1981   pred_tramp = scm_trampoline_1 (pred);
1982   SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
1983
1984   ret = SCM_EOL;
1985   p = &ret;
1986   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
1987     {
1988       SCM elem = SCM_CAR (lst);
1989       if (scm_is_false (pred_tramp (pred, elem)))
1990         goto done;
1991
1992       /* want this elem, tack it onto the end of ret */
1993       *p = scm_cons (elem, SCM_EOL);
1994       p = SCM_CDRLOC (*p);
1995     }
1996   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
1997
1998  done:
1999   return scm_values (scm_list_2 (ret, lst));
2000 }
2001 #undef FUNC_NAME
2002
2003
2004 SCM_DEFINE (scm_srfi1_span_x, "span!", 2, 0, 0,
2005             (SCM pred, SCM lst),
2006             "Return two values, the longest initial prefix of @var{lst}\n"
2007             "whose elements all satisfy the predicate @var{pred}, and the\n"
2008             "remainder of @var{lst}.  @var{lst} may be modified to form the\n"
2009             "return.")
2010 #define FUNC_NAME s_scm_srfi1_span_x
2011 {
2012   SCM upto, *p;
2013   scm_t_trampoline_1 pred_tramp;
2014
2015   pred_tramp = scm_trampoline_1 (pred);
2016   SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
2017
2018   p = &lst;
2019   for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
2020     {
2021       if (scm_is_false (pred_tramp (pred, SCM_CAR (upto))))
2022         goto done;
2023
2024       /* want this element */
2025       p = SCM_CDRLOC (upto);
2026     }
2027   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto), lst, SCM_ARG2, FUNC_NAME, "list");
2028
2029  done:
2030   *p = SCM_EOL;
2031   return scm_values (scm_list_2 (lst, upto));
2032 }
2033 #undef FUNC_NAME
2034
2035
2036 SCM_DEFINE (scm_srfi1_split_at, "split-at", 2, 0, 0,
2037             (SCM lst, SCM n),
2038             "Return two values (multiple values), being a list of the\n"
2039             "elements before index @var{n} in @var{lst}, and a list of those\n"
2040             "after.")
2041 #define FUNC_NAME s_scm_srfi1_split_at
2042 {
2043   size_t nn;
2044   /* pre is a list of elements before the i split point, loc is the CDRLOC
2045      of the last cell, ie. where to store to append to it */
2046   SCM pre = SCM_EOL;
2047   SCM *loc = &pre;
2048
2049   for (nn = scm_to_size_t (n); nn != 0; nn--)
2050     {
2051       SCM_VALIDATE_CONS (SCM_ARG1, lst);
2052
2053       *loc = scm_cons (SCM_CAR (lst), SCM_EOL);
2054       loc = SCM_CDRLOC (*loc);
2055       lst = SCM_CDR(lst);
2056     }
2057   return scm_values (scm_list_2 (pre, lst));
2058 }
2059 #undef FUNC_NAME
2060
2061
2062 SCM_DEFINE (scm_srfi1_split_at_x, "split-at!", 2, 0, 0,
2063             (SCM lst, SCM n),
2064             "Return two values (multiple values), being a list of the\n"
2065             "elements before index @var{n} in @var{lst}, and a list of those\n"
2066             "after.  @var{lst} is modified to form those values.")
2067 #define FUNC_NAME s_scm_srfi1_split_at
2068 {
2069   size_t nn;
2070   SCM upto = lst;
2071   SCM *loc = &lst;
2072
2073   for (nn = scm_to_size_t (n); nn != 0; nn--)
2074     {
2075       SCM_VALIDATE_CONS (SCM_ARG1, upto);
2076
2077       loc = SCM_CDRLOC (upto);
2078       upto = SCM_CDR (upto);
2079     }
2080
2081   *loc = SCM_EOL;
2082   return scm_values (scm_list_2 (lst, upto));
2083 }
2084 #undef FUNC_NAME
2085
2086
2087 SCM_DEFINE (scm_srfi1_take_x, "take!", 2, 0, 0,
2088             (SCM lst, SCM n),
2089             "Return a list containing the first @var{n} elements of\n"
2090             "@var{lst}.")
2091 #define FUNC_NAME s_scm_srfi1_take_x
2092 {
2093   long nn;
2094   SCM pos;
2095
2096   nn = scm_to_signed_integer (n, 0, LONG_MAX);
2097   if (nn == 0)
2098     return SCM_EOL;
2099
2100   pos = scm_list_tail (lst, scm_from_long (nn - 1));
2101
2102   /* Must have at least one cell left, mustn't have reached the end of an
2103      n-1 element list.  SCM_VALIDATE_CONS here gives the same error as
2104      scm_list_tail does on say an n-2 element list, though perhaps a range
2105      error would make more sense (for both).  */
2106   SCM_VALIDATE_CONS (SCM_ARG1, pos);
2107
2108   SCM_SETCDR (pos, SCM_EOL);
2109   return lst;
2110 }
2111 #undef FUNC_NAME
2112
2113
2114 SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0,
2115             (SCM lst, SCM n),
2116             "Return the a list containing the @var{n} last elements of\n"
2117             "@var{lst}.")
2118 #define FUNC_NAME s_scm_srfi1_take_right
2119 {
2120   SCM tail = scm_list_tail (lst, n);
2121   while (scm_is_pair (tail))
2122     {
2123       lst = SCM_CDR (lst);
2124       tail = SCM_CDR (tail);
2125     }
2126   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
2127   return lst;
2128 }
2129 #undef FUNC_NAME
2130
2131
2132 SCM_DEFINE (scm_srfi1_take_while, "take-while", 2, 0, 0,
2133             (SCM pred, SCM lst),
2134             "Return a new list which is the longest initial prefix of\n"
2135             "@var{lst} whose elements all satisfy the predicate @var{pred}.")
2136 #define FUNC_NAME s_scm_srfi1_take_while
2137 {
2138   scm_t_trampoline_1 pred_tramp;
2139   SCM ret, *p;
2140
2141   pred_tramp = scm_trampoline_1 (pred);
2142   SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
2143
2144   ret = SCM_EOL;
2145   p = &ret;
2146   for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
2147     {
2148       SCM elem = SCM_CAR (lst);
2149       if (scm_is_false (pred_tramp (pred, elem)))
2150         goto done;
2151
2152       /* want this elem, tack it onto the end of ret */
2153       *p = scm_cons (elem, SCM_EOL);
2154       p = SCM_CDRLOC (*p);
2155     }
2156   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
2157
2158  done:
2159   return ret;
2160 }
2161 #undef FUNC_NAME
2162
2163
2164 SCM_DEFINE (scm_srfi1_take_while_x, "take-while!", 2, 0, 0,
2165             (SCM pred, SCM lst),
2166             "Return the longest initial prefix of @var{lst} whose elements\n"
2167             "all satisfy the predicate @var{pred}.  @var{lst} may be\n"
2168             "modified to form the return.")
2169 #define FUNC_NAME s_scm_srfi1_take_while_x
2170 {
2171   SCM upto, *p;
2172   scm_t_trampoline_1 pred_tramp;
2173
2174   pred_tramp = scm_trampoline_1 (pred);
2175   SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
2176
2177   p = &lst;
2178   for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
2179     {
2180       if (scm_is_false (pred_tramp (pred, SCM_CAR (upto))))
2181         goto done;
2182
2183       /* want this element */
2184       p = SCM_CDRLOC (upto);
2185     }
2186   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto), lst, SCM_ARG2, FUNC_NAME, "list");
2187
2188  done:
2189   *p = SCM_EOL;
2190   return lst;
2191 }
2192 #undef FUNC_NAME
2193
2194
2195 SCM_DEFINE (scm_srfi1_tenth, "tenth", 1, 0, 0,
2196             (SCM lst),
2197             "Return the tenth element of @var{lst}.")
2198 #define FUNC_NAME s_scm_srfi1_tenth
2199 {
2200   return scm_list_ref (lst, scm_from_int (9));
2201 }
2202 #undef FUNC_NAME
2203
2204
2205 SCM_DEFINE (scm_srfi1_xcons, "xcons", 2, 0, 0,
2206             (SCM d, SCM a),
2207             "Like @code{cons}, but with interchanged arguments.  Useful\n"
2208             "mostly when passed to higher-order procedures.")
2209 #define FUNC_NAME s_scm_srfi1_xcons
2210 {
2211   return scm_cons (a, d);
2212 }
2213 #undef FUNC_NAME
2214
2215
2216 void
2217 scm_init_srfi_1 (void)
2218 {
2219   SCM the_root_module = scm_lookup_closure_module (SCM_BOOL_F);
2220 #ifndef SCM_MAGIC_SNARFER
2221 #include "srfi/srfi-1.x"
2222 #endif
2223   scm_c_extend_primitive_generic
2224     (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module, "map")),
2225      SCM_VARIABLE_REF (scm_c_lookup ("map")));
2226   scm_c_extend_primitive_generic
2227     (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module, "for-each")),
2228      SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
2229 }
2230
2231 /* End of srfi-1.c.  */