summaryrefslogtreecommitdiff
path: root/srfi/srfi-1.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-09-12 23:18:54 +0200
committerAndy Wingo <wingo@pobox.com>2010-09-12 23:29:11 +0200
commit37710f7e8f63f784de0343c1948e8afbbc10e395 (patch)
tree8d96cda7a538c82c3f981454392d799aafa5c1eb /srfi/srfi-1.c
parent4453f887ed6004126a73673f76853b30263209aa (diff)
downloadguile-37710f7e8f63f784de0343c1948e8afbbc10e395.tar.gz
move srfi-1 and srfi-60 C impl to libguile, without public C api
* libguile/srfi-1.c: * libguile/srfi-1.h: * libguile/srfi-60.c: * libguile/srfi-60.h: * libguile/ChangeLog-srfi: Move here, from the srfi/ dir. The C API is internal. Add API to register the extensions, called by init.c. * libguile/init.c: Verily, register srfi extensions. * libguile/Makefile.am: Add srfi files. * module/srfi/srfi-1.scm: * module/srfi/srfi-60.scm: Update load-extension invocation. * Makefile.am: * configure.ac: Remove srfi/ dir. * test-suite/standalone/Makefile.am: * test-suite/standalone/test-srfi-1.c: Remove srfi-1 C test, we don't support this API any more.
Diffstat (limited to 'srfi/srfi-1.c')
-rw-r--r--srfi/srfi-1.c1603
1 files changed, 0 insertions, 1603 deletions
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
deleted file mode 100644
index b81c90544..000000000
--- a/srfi/srfi-1.c
+++ /dev/null
@@ -1,1603 +0,0 @@
-/* srfi-1.c --- SRFI-1 procedures for Guile
- *
- * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006, 2008, 2009, 2010
- * Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <libguile.h>
-
-#include "srfi-1.h"
-
-/* The intent of this file was to gradually replace those Scheme
- * procedures in srfi-1.scm that extend core primitive procedures,
- * so that using srfi-1 won't have performance penalties.
- *
- * However, we now prefer to write these procedures in Scheme, let the compiler
- * optimize them, and have the VM execute them efficiently.
- */
-
-
-/* The `(srfi srfi-1)' module. */
-static SCM srfi1_module = SCM_BOOL_F;
-
-/* Cache variable NAME in C variable VAR. */
-#define CACHE_VAR(var, name) \
- static SCM var = SCM_BOOL_F; \
- if (scm_is_false (var)) \
- { \
- if (SCM_UNLIKELY (scm_is_false (srfi1_module))) \
- srfi1_module = scm_c_resolve_module ("srfi srfi-1"); \
- \
- var = scm_module_variable (srfi1_module, \
- scm_from_locale_symbol (name)); \
- if (SCM_UNLIKELY (scm_is_false (var))) \
- abort (); \
- \
- var = SCM_VARIABLE_REF (var); \
- }
-
-static long
-srfi1_ilength (SCM sx)
-{
- long i = 0;
- SCM tortoise = sx;
- SCM hare = sx;
-
- do {
- if (SCM_NULL_OR_NIL_P(hare)) return i;
- if (!scm_is_pair (hare)) return -2;
- hare = SCM_CDR(hare);
- i++;
- if (SCM_NULL_OR_NIL_P(hare)) return i;
- if (!scm_is_pair (hare)) return -2;
- hare = SCM_CDR(hare);
- i++;
- /* For every two steps the hare takes, the tortoise takes one. */
- tortoise = SCM_CDR(tortoise);
- }
- while (! scm_is_eq (hare, tortoise));
-
- /* If the tortoise ever catches the hare, then the list must contain
- a cycle. */
- return -1;
-}
-
-static SCM
-equal_trampoline (SCM proc, SCM arg1, SCM arg2)
-{
- return scm_equal_p (arg1, arg2);
-}
-
-/* list_copy_part() copies the first COUNT cells of LST, puts the result at
- *dst, and returns the SCM_CDRLOC of the last cell in that new list.
-
- This function is designed to be careful about LST possibly having changed
- in between the caller deciding what to copy, and the copy actually being
- done here. The COUNT ensures we terminate if LST has become circular,
- SCM_VALIDATE_CONS guards against a cdr in the list changed to some
- non-pair object. */
-
-#include <stdio.h>
-static SCM *
-list_copy_part (SCM lst, int count, SCM *dst)
-#define FUNC_NAME "list_copy_part"
-{
- SCM c;
- for ( ; count > 0; count--)
- {
- SCM_VALIDATE_CONS (SCM_ARGn, lst);
- c = scm_cons (SCM_CAR (lst), SCM_EOL);
- *dst = c;
- dst = SCM_CDRLOC (c);
- lst = SCM_CDR (lst);
- }
- return dst;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_alist_copy, "alist-copy", 1, 0, 0,
- (SCM alist),
- "Return a copy of @var{alist}, copying both the pairs comprising\n"
- "the list and those making the associations.")
-#define FUNC_NAME s_scm_srfi1_alist_copy
-{
- SCM ret, *p, elem, c;
-
- /* ret is the list to return. p is where to append to it, initially &ret
- then SCM_CDRLOC of the last pair. */
- ret = SCM_EOL;
- p = &ret;
-
- for ( ; scm_is_pair (alist); alist = SCM_CDR (alist))
- {
- elem = SCM_CAR (alist);
-
- /* each element of alist must be a pair */
- SCM_ASSERT_TYPE (scm_is_pair (elem), alist, SCM_ARG1, FUNC_NAME,
- "association list");
-
- c = scm_cons (scm_cons (SCM_CAR (elem), SCM_CDR (elem)), SCM_EOL);
- *p = c;
- p = SCM_CDRLOC (c);
- }
-
- /* alist must be a proper list */
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (alist), alist, SCM_ARG1, FUNC_NAME,
- "association list");
- return ret;
-}
-#undef FUNC_NAME
-
-
-
-SCM_DEFINE (scm_srfi1_append_reverse, "append-reverse", 2, 0, 0,
- (SCM revhead, SCM tail),
- "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
- "result. This is equivalent to @code{(append (reverse\n"
- "@var{rev-head}) @var{tail})}, but its implementation is more\n"
- "efficient.\n"
- "\n"
- "@example\n"
- "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
- "@end example")
-#define FUNC_NAME s_scm_srfi1_append_reverse
-{
- while (scm_is_pair (revhead))
- {
- /* copy first element of revhead onto front of tail */
- tail = scm_cons (SCM_CAR (revhead), tail);
- revhead = SCM_CDR (revhead);
- }
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
- "list");
- return tail;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_append_reverse_x, "append-reverse!", 2, 0, 0,
- (SCM revhead, SCM tail),
- "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
- "result. This is equivalent to @code{(append! (reverse!\n"
- "@var{rev-head}) @var{tail})}, but its implementation is more\n"
- "efficient.\n"
- "\n"
- "@example\n"
- "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
- "@end example\n"
- "\n"
- "@var{rev-head} may be modified in order to produce the result.")
-#define FUNC_NAME s_scm_srfi1_append_reverse_x
-{
- SCM newtail;
-
- while (scm_is_pair (revhead))
- {
- /* take the first cons cell from revhead */
- newtail = revhead;
- revhead = SCM_CDR (revhead);
-
- /* make it the new start of tail, appending the previous */
- SCM_SETCDR (newtail, tail);
- tail = newtail;
- }
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
- "list");
- return tail;
-}
-#undef FUNC_NAME
-
-SCM
-scm_srfi1_break (SCM pred, SCM lst)
-{
- CACHE_VAR (break_proc, "break");
- return scm_call_2 (break_proc, pred, lst);
-}
-
-SCM
-scm_srfi1_break_x (SCM pred, SCM lst)
-{
- CACHE_VAR (break_x, "break!");
- return scm_call_2 (break_x, pred, lst);
-}
-
-SCM
-scm_srfi1_car_plus_cdr (SCM pair)
-{
- CACHE_VAR (car_plus_cdr, "car+cdr");
- return scm_call_1 (car_plus_cdr, pair);
-}
-
-SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0,
- (SCM lstlst),
- "Construct a list by appending all lists in @var{lstlst}.\n"
- "\n"
- "@code{concatenate} is the same as @code{(apply append\n"
- "@var{lstlst})}. It exists because some Scheme implementations\n"
- "have a limit on the number of arguments a function takes, which\n"
- "the @code{apply} might exceed. In Guile there is no such\n"
- "limit.")
-#define FUNC_NAME s_scm_srfi1_concatenate
-{
- SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
- return scm_append (lstlst);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_concatenate_x, "concatenate!", 1, 0, 0,
- (SCM lstlst),
- "Construct a list by appending all lists in @var{lstlst}. Those\n"
- "lists may be modified to produce the result.\n"
- "\n"
- "@code{concatenate!} is the same as @code{(apply append!\n"
- "@var{lstlst})}. It exists because some Scheme implementations\n"
- "have a limit on the number of arguments a function takes, which\n"
- "the @code{apply} might exceed. In Guile there is no such\n"
- "limit.")
-#define FUNC_NAME s_scm_srfi1_concatenate
-{
- SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
- return scm_append_x (lstlst);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1,
- (SCM pred, SCM list1, SCM rest),
- "Return a count of the number of times @var{pred} returns true\n"
- "when called on elements from the given lists.\n"
- "\n"
- "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
- "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
- "corresponding @var{list1} @dots{} @var{lstN}. The first call is\n"
- "with the first element of each list, the second with the second\n"
- "element from each, and so on.\n"
- "\n"
- "Counting stops when the end of the shortest list is reached.\n"
- "At least one list must be non-circular.")
-#define FUNC_NAME s_scm_srfi1_count
-{
- long count;
- SCM lst;
- int argnum;
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- count = 0;
-
- if (scm_is_null (rest))
- {
- /* one list */
- SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
-
- for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
- count += scm_is_true (scm_call_1 (pred, SCM_CAR (list1)));
-
- /* check below that list1 is a proper list, and done */
- end_list1:
- lst = list1;
- argnum = 2;
- }
- else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
- {
- /* two lists */
- SCM list2;
-
- SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
-
- list2 = SCM_CAR (rest);
- for (;;)
- {
- if (! scm_is_pair (list1))
- goto end_list1;
- if (! scm_is_pair (list2))
- {
- lst = list2;
- argnum = 3;
- break;
- }
- count += scm_is_true (scm_call_2
- (pred, SCM_CAR (list1), SCM_CAR (list2)));
- list1 = SCM_CDR (list1);
- list2 = SCM_CDR (list2);
- }
- }
- else
- {
- /* three or more lists */
- SCM vec, args, a;
- size_t len, i;
-
- /* vec is the list arguments */
- vec = scm_vector (scm_cons (list1, rest));
- len = SCM_SIMPLE_VECTOR_LENGTH (vec);
-
- /* args is the argument list to pass to pred, same length as vec,
- re-used for each call */
- args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
-
- for (;;)
- {
- /* first elem of each list in vec into args, and step those
- vec entries onto their next element */
- for (i = 0, a = args, argnum = 2;
- i < len;
- i++, a = SCM_CDR (a), argnum++)
- {
- lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
- if (! scm_is_pair (lst))
- goto check_lst_and_done;
- SCM_SETCAR (a, SCM_CAR (lst)); /* arg for pred */
- SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
- }
-
- count += scm_is_true (scm_apply (pred, args, SCM_EOL));
- }
- }
-
- check_lst_and_done:
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
- return scm_from_long (count);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_delete, "delete", 2, 1, 0,
- (SCM x, SCM lst, SCM pred),
- "Return a list containing the elements of @var{lst} but with\n"
- "those equal to @var{x} deleted. The returned elements will be\n"
- "in the same order as they were in @var{lst}.\n"
- "\n"
- "Equality is determined by @var{pred}, or @code{equal?} if not\n"
- "given. An equality call is made just once for each element,\n"
- "but the order in which the calls are made on the elements is\n"
- "unspecified.\n"
- "\n"
- "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
- "given @var{x} is first. This means for instance elements\n"
- "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
- "\n"
- "@var{lst} is not modified, but the returned list might share a\n"
- "common tail with @var{lst}.")
-#define FUNC_NAME s_scm_srfi1_delete
-{
- SCM ret, *p, keeplst;
- int count;
-
- if (SCM_UNBNDP (pred))
- return scm_delete (x, lst);
-
- SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG3, FUNC_NAME);
-
- /* ret is the return list being constructed. p is where to append to it,
- initially &ret then SCM_CDRLOC of the last pair. lst progresses as
- elements are considered.
-
- Elements to be retained are not immediately copied, instead keeplst is
- the last pair in lst which is to be retained but not yet copied, count
- is how many from there are wanted. When there's no more deletions, *p
- can be set to keeplst to share the remainder of the original lst. (The
- entire original lst if there's no deletions at all.) */
-
- keeplst = lst;
- count = 0;
- p = &ret;
-
- for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
- {
- if (scm_is_true (scm_call_2 (pred, x, SCM_CAR (lst))))
- {
- /* delete this element, so copy those at keeplst */
- p = list_copy_part (keeplst, count, p);
- keeplst = SCM_CDR (lst);
- count = 0;
- }
- else
- {
- /* keep this element */
- count++;
- }
- }
-
- /* final retained elements */
- *p = keeplst;
-
- /* demand that lst was a proper list */
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
-
- return ret;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_delete_x, "delete!", 2, 1, 0,
- (SCM x, SCM lst, SCM pred),
- "Return a list containing the elements of @var{lst} but with\n"
- "those equal to @var{x} deleted. The returned elements will be\n"
- "in the same order as they were in @var{lst}.\n"
- "\n"
- "Equality is determined by @var{pred}, or @code{equal?} if not\n"
- "given. An equality call is made just once for each element,\n"
- "but the order in which the calls are made on the elements is\n"
- "unspecified.\n"
- "\n"
- "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
- "given @var{x} is first. This means for instance elements\n"
- "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
- "\n"
- "@var{lst} may be modified to construct the returned list.")
-#define FUNC_NAME s_scm_srfi1_delete_x
-{
- SCM walk;
- SCM *prev;
-
- if (SCM_UNBNDP (pred))
- return scm_delete_x (x, lst);
-
- SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG3, FUNC_NAME);
-
- for (prev = &lst, walk = lst;
- scm_is_pair (walk);
- walk = SCM_CDR (walk))
- {
- if (scm_is_true (scm_call_2 (pred, x, SCM_CAR (walk))))
- *prev = SCM_CDR (walk);
- else
- prev = SCM_CDRLOC (walk);
- }
-
- /* demand the input was a proper list */
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk), walk, SCM_ARG2, FUNC_NAME,"list");
- return lst;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_delete_duplicates, "delete-duplicates", 1, 1, 0,
- (SCM lst, SCM pred),
- "Return a list containing the elements of @var{lst} but without\n"
- "duplicates.\n"
- "\n"
- "When elements are equal, only the first in @var{lst} is\n"
- "retained. Equal elements can be anywhere in @var{lst}, they\n"
- "don't have to be adjacent. The returned list will have the\n"
- "retained elements in the same order as they were in @var{lst}.\n"
- "\n"
- "Equality is determined by @var{pred}, or @code{equal?} if not\n"
- "given. Calls @code{(pred x y)} are made with element @var{x}\n"
- "being before @var{y} in @var{lst}. A call is made at most once\n"
- "for each combination, but the sequence of the calls across the\n"
- "elements is unspecified.\n"
- "\n"
- "@var{lst} is not modified, but the return might share a common\n"
- "tail with @var{lst}.\n"
- "\n"
- "In the worst case, this is an @math{O(N^2)} algorithm because\n"
- "it must check each element against all those preceding it. For\n"
- "long lists it is more efficient to sort and then compare only\n"
- "adjacent elements.")
-#define FUNC_NAME s_scm_srfi1_delete_duplicates
-{
- scm_t_trampoline_2 equal_p;
- SCM ret, *p, keeplst, item, l;
- int count, i;
-
- /* ret is the new list constructed. p is where to append, initially &ret
- then SCM_CDRLOC of the last pair. lst is advanced as each element is
- considered.
-
- Elements retained are not immediately appended to ret, instead keeplst
- is the last pair in lst which is to be kept but is not yet copied.
- Initially this is the first pair of lst, since the first element is
- always retained.
-
- *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
- the elements retained, making the equality search loop easy.
-
- If an item must be deleted, elements from keeplst (inclusive) to lst
- (exclusive) must be copied and appended to ret. When there's no more
- deletions, *p is left set to keeplst, so ret shares structure with the
- original lst. (ret will be the entire original lst if there are no
- deletions.) */
-
- /* skip to end if an empty list (or something invalid) */
- ret = SCM_EOL;
-
- if (SCM_UNBNDP (pred))
- equal_p = equal_trampoline;
- else
- {
- SCM_VALIDATE_PROC (SCM_ARG2, pred);
- equal_p = scm_call_2;
- }
-
- keeplst = lst;
- count = 0;
- p = &ret;
-
- for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
- {
- item = SCM_CAR (lst);
-
- /* look for item in "ret" list */
- for (l = ret; scm_is_pair (l); l = SCM_CDR (l))
- {
- if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
- {
- /* "item" is a duplicate, so copy keeplst onto ret */
- duplicate:
- p = list_copy_part (keeplst, count, p);
-
- keeplst = SCM_CDR (lst); /* elem after the one deleted */
- count = 0;
- goto next_elem;
- }
- }
-
- /* look for item in "keeplst" list
- be careful traversing, in case nasty code changed the cdrs */
- for (i = 0, l = keeplst;
- i < count && scm_is_pair (l);
- i++, l = SCM_CDR (l))
- if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
- goto duplicate;
-
- /* keep this element */
- count++;
-
- next_elem:
- ;
- }
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list");
-
- /* share tail of keeplst items */
- *p = keeplst;
-
- return ret;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0,
- (SCM lst, SCM pred),
- "Return a list containing the elements of @var{lst} but without\n"
- "duplicates.\n"
- "\n"
- "When elements are equal, only the first in @var{lst} is\n"
- "retained. Equal elements can be anywhere in @var{lst}, they\n"
- "don't have to be adjacent. The returned list will have the\n"
- "retained elements in the same order as they were in @var{lst}.\n"
- "\n"
- "Equality is determined by @var{pred}, or @code{equal?} if not\n"
- "given. Calls @code{(pred x y)} are made with element @var{x}\n"
- "being before @var{y} in @var{lst}. A call is made at most once\n"
- "for each combination, but the sequence of the calls across the\n"
- "elements is unspecified.\n"
- "\n"
- "@var{lst} may be modified to construct the returned list.\n"
- "\n"
- "In the worst case, this is an @math{O(N^2)} algorithm because\n"
- "it must check each element against all those preceding it. For\n"
- "long lists it is more efficient to sort and then compare only\n"
- "adjacent elements.")
-#define FUNC_NAME s_scm_srfi1_delete_duplicates_x
-{
- scm_t_trampoline_2 equal_p;
- SCM ret, endret, item, l;
-
- /* ret is the return list, constructed from the pairs in lst. endret is
- the last pair of ret, initially the first pair. lst is advanced as
- elements are considered. */
-
- /* skip to end if an empty list (or something invalid) */
- ret = lst;
- if (scm_is_pair (lst))
- {
- if (SCM_UNBNDP (pred))
- equal_p = equal_trampoline;
- else
- {
- SCM_VALIDATE_PROC (SCM_ARG2, pred);
- equal_p = scm_call_2;
- }
-
- endret = ret;
-
- /* loop over lst elements starting from second */
- for (;;)
- {
- lst = SCM_CDR (lst);
- if (! scm_is_pair (lst))
- break;
- item = SCM_CAR (lst);
-
- /* is item equal to any element from ret to endret (inclusive)? */
- l = ret;
- for (;;)
- {
- if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
- break; /* equal, forget this element */
-
- if (scm_is_eq (l, endret))
- {
- /* not equal to any, so append this pair */
- SCM_SETCDR (endret, lst);
- endret = lst;
- break;
- }
- l = SCM_CDR (l);
- }
- }
-
- /* terminate, in case last element was deleted */
- SCM_SETCDR (endret, SCM_EOL);
- }
-
- /* demand that lst was a proper list */
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list");
-
- return ret;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_drop_right, "drop-right", 2, 0, 0,
- (SCM lst, SCM n),
- "Return a new list containing all except the last @var{n}\n"
- "elements of @var{lst}.")
-#define FUNC_NAME s_scm_srfi1_drop_right
-{
- SCM tail = scm_list_tail (lst, n);
- SCM ret = SCM_EOL;
- SCM *rend = &ret;
- while (scm_is_pair (tail))
- {
- *rend = scm_cons (SCM_CAR (lst), SCM_EOL);
- rend = SCM_CDRLOC (*rend);
-
- lst = SCM_CDR (lst);
- tail = SCM_CDR (tail);
- }
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
- return ret;
-}
-#undef FUNC_NAME
-
-SCM
-scm_srfi1_drop_right_x (SCM lst, SCM n)
-{
- CACHE_VAR (drop_right_x, "drop-right!");
- return scm_call_2 (drop_right_x, lst, n);
-}
-
-SCM
-scm_srfi1_drop_while (SCM pred, SCM lst)
-{
- CACHE_VAR (drop_while, "drop-while");
- return scm_call_2 (drop_while, pred, lst);
-}
-
-SCM
-scm_srfi1_eighth (SCM lst)
-{
- CACHE_VAR (eighth, "eighth");
- return scm_call_1 (eighth, lst);
-}
-
-SCM
-scm_srfi1_fifth (SCM lst)
-{
- CACHE_VAR (fifth, "fifth");
- return scm_call_1 (fifth, lst);
-}
-
-
-SCM_DEFINE (scm_srfi1_filter_map, "filter-map", 2, 0, 1,
- (SCM proc, SCM list1, SCM rest),
- "Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
- "return a list of the results as per SRFI-1 @code{map}, except\n"
- "that any @code{#f} results are omitted from the list returned.")
-#define FUNC_NAME s_scm_srfi1_filter_map
-{
- SCM ret, *loc, elem, newcell, lst;
- int argnum;
-
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- ret = SCM_EOL;
- loc = &ret;
-
- if (scm_is_null (rest))
- {
- /* one list */
- SCM_VALIDATE_PROC (SCM_ARG1, proc);
-
- for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
- {
- elem = scm_call_1 (proc, SCM_CAR (list1));
- if (scm_is_true (elem))
- {
- newcell = scm_cons (elem, SCM_EOL);
- *loc = newcell;
- loc = SCM_CDRLOC (newcell);
- }
- }
-
- /* check below that list1 is a proper list, and done */
- end_list1:
- lst = list1;
- argnum = 2;
- }
- else if (scm_is_null (SCM_CDR (rest)))
- {
- /* two lists */
- SCM list2 = SCM_CAR (rest);
- SCM_VALIDATE_PROC (SCM_ARG1, proc);
-
- for (;;)
- {
- if (! scm_is_pair (list1))
- goto end_list1;
- if (! scm_is_pair (list2))
- {
- lst = list2;
- argnum = 3;
- goto check_lst_and_done;
- }
- elem = scm_call_2 (proc, SCM_CAR (list1), SCM_CAR (list2));
- if (scm_is_true (elem))
- {
- newcell = scm_cons (elem, SCM_EOL);
- *loc = newcell;
- loc = SCM_CDRLOC (newcell);
- }
- list1 = SCM_CDR (list1);
- list2 = SCM_CDR (list2);
- }
- }
- else
- {
- /* three or more lists */
- SCM vec, args, a;
- size_t len, i;
-
- /* vec is the list arguments */
- vec = scm_vector (scm_cons (list1, rest));
- len = SCM_SIMPLE_VECTOR_LENGTH (vec);
-
- /* args is the argument list to pass to proc, same length as vec,
- re-used for each call */
- args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
-
- for (;;)
- {
- /* first elem of each list in vec into args, and step those
- vec entries onto their next element */
- for (i = 0, a = args, argnum = 2;
- i < len;
- i++, a = SCM_CDR (a), argnum++)
- {
- lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
- if (! scm_is_pair (lst))
- goto check_lst_and_done;
- SCM_SETCAR (a, SCM_CAR (lst)); /* arg for proc */
- SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
- }
-
- elem = scm_apply (proc, args, SCM_EOL);
- if (scm_is_true (elem))
- {
- newcell = scm_cons (elem, SCM_EOL);
- *loc = newcell;
- loc = SCM_CDRLOC (newcell);
- }
- }
- }
-
- check_lst_and_done:
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
- return ret;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_find, "find", 2, 0, 0,
- (SCM pred, SCM lst),
- "Return the first element of @var{lst} which satisfies the\n"
- "predicate @var{pred}, or return @code{#f} if no such element is\n"
- "found.")
-#define FUNC_NAME s_scm_srfi1_find
-{
- SCM_VALIDATE_PROC (SCM_ARG1, pred);
-
- for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
- {
- SCM elem = SCM_CAR (lst);
- if (scm_is_true (scm_call_1 (pred, elem)))
- return elem;
- }
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
-
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0,
- (SCM pred, SCM lst),
- "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
- "predicate @var{pred}, or return @code{#f} if no such element is\n"
- "found.")
-#define FUNC_NAME s_scm_srfi1_find_tail
-{
- SCM_VALIDATE_PROC (SCM_ARG1, pred);
-
- for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
- if (scm_is_true (scm_call_1 (pred, SCM_CAR (lst))))
- return lst;
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
-
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM
-scm_srfi1_fold (SCM proc, SCM init, SCM list1, SCM rest)
-{
- CACHE_VAR (fold, "fold");
- return scm_apply_3 (fold, proc, init, list1, rest);
-}
-
-SCM
-scm_srfi1_last (SCM lst)
-{
- CACHE_VAR (last, "last");
- return scm_call_1 (last, lst);
-}
-
-SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
- (SCM lst),
- "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
- "circular.")
-#define FUNC_NAME s_scm_srfi1_length_plus
-{
- long len = scm_ilength (lst);
- return (len >= 0 ? SCM_I_MAKINUM (len) : SCM_BOOL_F);
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_srfi1_list_index (SCM pred, SCM list1, SCM rest)
-{
- CACHE_VAR (list_index, "list-index");
- return scm_apply_2 (list_index, pred, list1, rest);
-}
-
-/* This routine differs from the core list-copy in allowing improper lists.
- Maybe the core could allow them similarly. */
-
-SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0,
- (SCM lst),
- "Return a copy of the given list @var{lst}.\n"
- "\n"
- "@var{lst} can be a proper or improper list. And if @var{lst}\n"
- "is not a pair then it's treated as the final tail of an\n"
- "improper list and simply returned.")
-#define FUNC_NAME s_scm_srfi1_list_copy
-{
- SCM newlst;
- SCM * fill_here;
- SCM from_here;
-
- newlst = lst;
- fill_here = &newlst;
- from_here = lst;
-
- while (scm_is_pair (from_here))
- {
- SCM c;
- c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
- *fill_here = c;
- fill_here = SCM_CDRLOC (c);
- from_here = SCM_CDR (from_here);
- }
- return newlst;
-}
-#undef FUNC_NAME
-
-SCM
-scm_srfi1_list_tabulate (SCM n, SCM proc)
-{
- CACHE_VAR (list_tabulate, "list-tabulate");
- return scm_call_2 (list_tabulate, n, proc);
-}
-
-SCM
-scm_srfi1_lset_adjoin (SCM equal, SCM lst, SCM rest)
-{
- CACHE_VAR (lset_adjoin, "lset-adjoin");
- return scm_apply_1 (lset_adjoin, lst, rest);
-}
-
-SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1,
- (SCM equal, SCM lst, SCM rest),
- "Return @var{lst} with any elements in the lists in @var{rest}\n"
- "removed (ie.@: subtracted). For only one @var{lst} argument,\n"
- "just that list is returned.\n"
- "\n"
- "The given @var{equal} procedure is used for comparing elements,\n"
- "called as @code{(@var{equal} elem1 elemN)}. The first argument\n"
- "is from @var{lst} and the second from one of the subsequent\n"
- "lists. But exactly which calls are made and in what order is\n"
- "unspecified.\n"
- "\n"
- "@example\n"
- "(lset-difference! eqv? (list 'x 'y)) @result{} (x y)\n"
- "(lset-difference! eqv? (list 1 2 3) '(3 1)) @result{} (2)\n"
- "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n"
- "@end example\n"
- "\n"
- "@code{lset-difference!} may modify @var{lst} to form its\n"
- "result.")
-#define FUNC_NAME s_scm_srfi1_lset_difference_x
-{
- SCM ret, *pos, elem, r, b;
- int argnum;
-
- SCM_VALIDATE_PROC (SCM_ARG1, equal);
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- ret = SCM_EOL;
- pos = &ret;
- for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
- {
- elem = SCM_CAR (lst);
-
- for (r = rest, argnum = SCM_ARG3;
- scm_is_pair (r);
- r = SCM_CDR (r), argnum++)
- {
- for (b = SCM_CAR (r); scm_is_pair (b); b = SCM_CDR (b))
- if (scm_is_true (scm_call_2 (equal, elem, SCM_CAR (b))))
- goto next_elem; /* equal to elem, so drop that elem */
-
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b), b, argnum, FUNC_NAME,"list");
- }
-
- /* elem not equal to anything in later lists, so keep it */
- *pos = lst;
- pos = SCM_CDRLOC (lst);
-
- next_elem:
- ;
- }
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
-
- *pos = SCM_EOL;
- return ret;
-}
-#undef FUNC_NAME
-
-
-/* Typechecking for multi-argument MAP and FOR-EACH.
-
- Verify that each element of the vector ARGV, except for the first,
- is a list and return minimum length. Attribute errors to WHO,
- and claim that the i'th element of ARGV is WHO's i+2'th argument. */
-static inline int
-check_map_args (SCM argv,
- long len,
- SCM gf,
- SCM proc,
- SCM args,
- const char *who)
-{
- long i;
- SCM elt;
-
- for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
- {
- long elt_len;
- elt = SCM_SIMPLE_VECTOR_REF (argv, i);
-
- if (!(scm_is_null (elt) || scm_is_pair (elt)))
- goto check_map_error;
-
- elt_len = srfi1_ilength (elt);
- if (elt_len < -1)
- goto check_map_error;
-
- if (len < 0 || (elt_len >= 0 && elt_len < len))
- len = elt_len;
- }
-
- if (len < 0)
- {
- /* i == 0 */
- elt = SCM_EOL;
- check_map_error:
- if (gf)
- scm_apply_generic (gf, scm_cons (proc, args));
- else
- scm_wrong_type_arg (who, i + 2, elt);
- }
-
- scm_remember_upto_here_1 (argv);
- return len;
-}
-
-
-SCM_GPROC (s_srfi1_map, "map", 2, 0, 1, scm_srfi1_map, g_srfi1_map);
-
-/* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
- sequentially, starting with the first element(s). This is used in
- the Scheme procedure `map-in-order', which guarantees sequential
- behaviour, is implemented using scm_map. If the behaviour changes,
- we need to update `map-in-order'.
-*/
-
-SCM
-scm_srfi1_map (SCM proc, SCM arg1, SCM args)
-#define FUNC_NAME s_srfi1_map
-{
- long i, len;
- SCM res = SCM_EOL;
- SCM *pres = &res;
-
- len = srfi1_ilength (arg1);
- SCM_GASSERTn ((scm_is_null (arg1) || scm_is_pair (arg1)) && len >= -1,
- g_srfi1_map,
- scm_cons2 (proc, arg1, args), SCM_ARG2, s_srfi1_map);
- SCM_VALIDATE_REST_ARGUMENT (args);
- if (scm_is_null (args))
- {
- SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_srfi1_map,
- proc, arg1, SCM_ARG1, s_srfi1_map);
- SCM_GASSERT2 (len >= 0, g_srfi1_map, proc, arg1, SCM_ARG2, s_srfi1_map);
- while (SCM_NIMP (arg1))
- {
- *pres = scm_list_1 (scm_call_1 (proc, SCM_CAR (arg1)));
- pres = SCM_CDRLOC (*pres);
- arg1 = SCM_CDR (arg1);
- }
- return res;
- }
- if (scm_is_null (SCM_CDR (args)))
- {
- SCM arg2 = SCM_CAR (args);
- int len2 = srfi1_ilength (arg2);
- SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_srfi1_map,
- scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_map);
- if (len < 0 || (len2 >= 0 && len2 < len))
- len = len2;
- SCM_GASSERTn ((scm_is_null (arg2) || scm_is_pair (arg2))
- && len >= 0 && len2 >= -1,
- g_srfi1_map,
- scm_cons2 (proc, arg1, args),
- len2 >= 0 ? SCM_ARG2 : SCM_ARG3,
- s_srfi1_map);
- while (len > 0)
- {
- *pres = scm_list_1 (scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
- pres = SCM_CDRLOC (*pres);
- arg1 = SCM_CDR (arg1);
- arg2 = SCM_CDR (arg2);
- --len;
- }
- return res;
- }
- args = scm_vector (arg1 = scm_cons (arg1, args));
- len = check_map_args (args, len, g_srfi1_map, proc, arg1, s_srfi1_map);
- while (len > 0)
- {
- arg1 = SCM_EOL;
- for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
- arg1 = scm_cons (SCM_CAR (elt), arg1);
- SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
- }
- *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
- pres = SCM_CDRLOC (*pres);
- --len;
- }
- return res;
-}
-#undef FUNC_NAME
-
-SCM_REGISTER_PROC (s_srfi1_map_in_order, "map-in-order", 2, 0, 1, scm_srfi1_map);
-
-SCM_GPROC (s_srfi1_for_each, "for-each", 2, 0, 1, scm_srfi1_for_each, g_srfi1_for_each);
-
-SCM
-scm_srfi1_for_each (SCM proc, SCM arg1, SCM args)
-#define FUNC_NAME s_srfi1_for_each
-{
- long i, len;
- len = srfi1_ilength (arg1);
- SCM_GASSERTn ((scm_is_null (arg1) || scm_is_pair (arg1)) && len >= -1,
- g_srfi1_for_each, scm_cons2 (proc, arg1, args),
- SCM_ARG2, s_srfi1_for_each);
- SCM_VALIDATE_REST_ARGUMENT (args);
- if (scm_is_null (args))
- {
- SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_srfi1_for_each,
- proc, arg1, SCM_ARG1, s_srfi1_for_each);
- SCM_GASSERT2 (len >= 0, g_srfi1_for_each, proc, arg1,
- SCM_ARG2, s_srfi1_map);
- while (SCM_NIMP (arg1))
- {
- scm_call_1 (proc, SCM_CAR (arg1));
- arg1 = SCM_CDR (arg1);
- }
- return SCM_UNSPECIFIED;
- }
- if (scm_is_null (SCM_CDR (args)))
- {
- SCM arg2 = SCM_CAR (args);
- int len2 = srfi1_ilength (arg2);
- SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_srfi1_for_each,
- scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_for_each);
- if (len < 0 || (len2 >= 0 && len2 < len))
- len = len2;
- SCM_GASSERTn ((scm_is_null (arg2) || scm_is_pair (arg2))
- && len >= 0 && len2 >= -1,
- g_srfi1_for_each,
- scm_cons2 (proc, arg1, args),
- len2 >= 0 ? SCM_ARG2 : SCM_ARG3,
- s_srfi1_for_each);
- while (len > 0)
- {
- scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2));
- arg1 = SCM_CDR (arg1);
- arg2 = SCM_CDR (arg2);
- --len;
- }
- return SCM_UNSPECIFIED;
- }
- args = scm_vector (arg1 = scm_cons (arg1, args));
- len = check_map_args (args, len, g_srfi1_for_each, proc, arg1,
- s_srfi1_for_each);
- while (len > 0)
- {
- arg1 = SCM_EOL;
- for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
- arg1 = scm_cons (SCM_CAR (elt), arg1);
- SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
- }
- scm_apply (proc, arg1, SCM_EOL);
- --len;
- }
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0,
- (SCM x, SCM lst, SCM pred),
- "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
- "to @var{x}. If @var{x} does not appear in @var{lst}, return\n"
- "@code{#f}.\n"
- "\n"
- "Equality is determined by @code{equal?}, or by the equality\n"
- "predicate @var{=} if given. @var{=} is called @code{(= @var{x}\n"
- "elem)}, ie.@: with the given @var{x} first, so for example to\n"
- "find the first element greater than 5,\n"
- "\n"
- "@example\n"
- "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
- "@end example\n"
- "\n"
- "This version of @code{member} extends the core @code{member} by\n"
- "accepting an equality predicate.")
-#define FUNC_NAME s_scm_srfi1_member
-{
- scm_t_trampoline_2 equal_p;
- SCM_VALIDATE_LIST (2, lst);
- if (SCM_UNBNDP (pred))
- equal_p = equal_trampoline;
- else
- {
- SCM_VALIDATE_PROC (SCM_ARG3, pred);
- equal_p = scm_call_2;
- }
- for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
- {
- if (scm_is_true (equal_p (pred, x, SCM_CAR (lst))))
- return lst;
- }
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
- (SCM key, SCM alist, SCM pred),
- "Behaves like @code{assq} but uses third argument @var{pred?}\n"
- "for key comparison. If @var{pred?} is not supplied,\n"
- "@code{equal?} is used. (Extended from R5RS.)\n")
-#define FUNC_NAME s_scm_srfi1_assoc
-{
- SCM ls = alist;
- scm_t_trampoline_2 equal_p;
- if (SCM_UNBNDP (pred))
- equal_p = equal_trampoline;
- else
- {
- SCM_VALIDATE_PROC (SCM_ARG3, pred);
- equal_p = scm_call_2;
- }
- for(; scm_is_pair (ls); ls = SCM_CDR (ls))
- {
- SCM tmp = SCM_CAR (ls);
- SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
- "association list");
- if (scm_is_true (equal_p (pred, key, SCM_CAR (tmp))))
- return tmp;
- }
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
- "association list");
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_srfi1_ninth (SCM lst)
-{
- CACHE_VAR (ninth, "ninth");
- return scm_call_1 (ninth, lst);
-}
-
-SCM
-scm_srfi1_not_pair_p (SCM obj)
-{
- CACHE_VAR (not_pair_p, "not-pair?");
- return scm_call_1 (not_pair_p, obj);
-}
-
-SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
- (SCM pred, SCM list),
- "Partition the elements of @var{list} with predicate @var{pred}.\n"
- "Return two values: the list of elements satifying @var{pred} and\n"
- "the list of elements @emph{not} satisfying @var{pred}. The order\n"
- "of the output lists follows the order of @var{list}. @var{list}\n"
- "is not mutated. One of the output lists may share memory with @var{list}.\n")
-#define FUNC_NAME s_scm_srfi1_partition
-{
- /* In this implementation, the output lists don't share memory with
- list, because it's probably not worth the effort. */
- SCM orig_list = list;
- SCM kept = scm_cons(SCM_EOL, SCM_EOL);
- SCM kept_tail = kept;
- SCM dropped = scm_cons(SCM_EOL, SCM_EOL);
- SCM dropped_tail = dropped;
-
- SCM_VALIDATE_PROC (SCM_ARG1, pred);
-
- for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) {
- SCM elt, new_tail;
-
- /* Make sure LIST is not a dotted list. */
- SCM_ASSERT (scm_is_pair (list), orig_list, SCM_ARG2, FUNC_NAME);
-
- elt = SCM_CAR (list);
- new_tail = scm_cons (SCM_CAR (list), SCM_EOL);
-
- if (scm_is_true (scm_call_1 (pred, elt))) {
- SCM_SETCDR(kept_tail, new_tail);
- kept_tail = new_tail;
- }
- else {
- SCM_SETCDR(dropped_tail, new_tail);
- dropped_tail = new_tail;
- }
- }
- /* re-use the initial conses for the values list */
- SCM_SETCAR(kept, SCM_CDR(kept));
- SCM_SETCDR(kept, dropped);
- SCM_SETCAR(dropped, SCM_CDR(dropped));
- SCM_SETCDR(dropped, SCM_EOL);
- return scm_values(kept);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0,
- (SCM pred, SCM lst),
- "Split @var{lst} into those elements which do and don't satisfy\n"
- "the predicate @var{pred}.\n"
- "\n"
- "The return is two values (@pxref{Multiple Values}), the first\n"
- "being a list of all elements from @var{lst} which satisfy\n"
- "@var{pred}, the second a list of those which do not.\n"
- "\n"
- "The elements in the result lists are in the same order as in\n"
- "@var{lst} but the order in which the calls @code{(@var{pred}\n"
- "elem)} are made on the list elements is unspecified.\n"
- "\n"
- "@var{lst} may be modified to construct the return lists.")
-#define FUNC_NAME s_scm_srfi1_partition_x
-{
- SCM tlst, flst, *tp, *fp;
-
- SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
-
- /* tlst and flst are the lists of true and false elements. tp and fp are
- where to store to append to them, initially &tlst and &flst, then
- SCM_CDRLOC of the last pair in the respective lists. */
-
- tlst = SCM_EOL;
- flst = SCM_EOL;
- tp = &tlst;
- fp = &flst;
-
- for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
- {
- if (scm_is_true (scm_call_1 (pred, SCM_CAR (lst))))
- {
- *tp = lst;
- tp = SCM_CDRLOC (lst);
- }
- else
- {
- *fp = lst;
- fp = SCM_CDRLOC (lst);
- }
- }
-
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
-
- /* terminate whichever didn't get the last element(s) */
- *tp = SCM_EOL;
- *fp = SCM_EOL;
-
- return scm_values (scm_list_2 (tlst, flst));
-}
-#undef FUNC_NAME
-
-SCM
-scm_srfi1_reduce (SCM proc, SCM def, SCM lst)
-{
- CACHE_VAR (reduce, "reduce");
- return scm_call_3 (reduce, proc, def, lst);
-}
-
-SCM
-scm_srfi1_reduce_right (SCM proc, SCM def, SCM lst)
-{
- CACHE_VAR (reduce_right, "reduce-right");
- return scm_call_3 (reduce_right, proc, def, lst);
-}
-
-SCM_DEFINE (scm_srfi1_remove, "remove", 2, 0, 0,
- (SCM pred, SCM list),
- "Return a list containing all elements from @var{lst} which do\n"
- "not satisfy the predicate @var{pred}. The elements in the\n"
- "result list have the same order as in @var{lst}. The order in\n"
- "which @var{pred} is applied to the list elements is not\n"
- "specified.")
-#define FUNC_NAME s_scm_srfi1_remove
-{
- SCM walk;
- SCM *prev;
- SCM res = SCM_EOL;
- SCM_VALIDATE_PROC (SCM_ARG1, pred);
- SCM_VALIDATE_LIST (2, list);
-
- for (prev = &res, walk = list;
- scm_is_pair (walk);
- walk = SCM_CDR (walk))
- {
- if (scm_is_false (scm_call_1 (pred, SCM_CAR (walk))))
- {
- *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
- prev = SCM_CDRLOC (*prev);
- }
- }
-
- return res;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
- (SCM pred, SCM list),
- "Return a list containing all elements from @var{list} which do\n"
- "not satisfy the predicate @var{pred}. The elements in the\n"
- "result list have the same order as in @var{list}. The order in\n"
- "which @var{pred} is applied to the list elements is not\n"
- "specified. @var{list} may be modified to build the return\n"
- "list.")
-#define FUNC_NAME s_scm_srfi1_remove_x
-{
- SCM walk;
- SCM *prev;
- SCM_VALIDATE_PROC (SCM_ARG1, pred);
- SCM_VALIDATE_LIST (2, list);
-
- for (prev = &list, walk = list;
- scm_is_pair (walk);
- walk = SCM_CDR (walk))
- {
- if (scm_is_false (scm_call_1 (pred, SCM_CAR (walk))))
- prev = SCM_CDRLOC (walk);
- else
- *prev = SCM_CDR (walk);
- }
-
- return list;
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_srfi1_seventh (SCM lst)
-{
- CACHE_VAR (seventh, "seventh");
- return scm_call_1 (seventh, lst);
-}
-
-SCM
-scm_srfi1_sixth (SCM lst)
-{
- CACHE_VAR (sixth, "sixth");
- return scm_call_1 (sixth, lst);
-}
-
-SCM
-scm_srfi1_span (SCM pred, SCM lst)
-{
- CACHE_VAR (span, "span");
- return scm_call_2 (span, pred, lst);
-}
-
-SCM
-scm_srfi1_span_x (SCM pred, SCM lst)
-{
- CACHE_VAR (span_x, "span!");
- return scm_call_2 (span_x, pred, lst);
-}
-
-SCM_DEFINE (scm_srfi1_split_at, "split-at", 2, 0, 0,
- (SCM lst, SCM n),
- "Return two values (multiple values), being a list of the\n"
- "elements before index @var{n} in @var{lst}, and a list of those\n"
- "after.")
-#define FUNC_NAME s_scm_srfi1_split_at
-{
- size_t nn;
- /* pre is a list of elements before the i split point, loc is the CDRLOC
- of the last cell, ie. where to store to append to it */
- SCM pre = SCM_EOL;
- SCM *loc = &pre;
-
- for (nn = scm_to_size_t (n); nn != 0; nn--)
- {
- SCM_VALIDATE_CONS (SCM_ARG1, lst);
-
- *loc = scm_cons (SCM_CAR (lst), SCM_EOL);
- loc = SCM_CDRLOC (*loc);
- lst = SCM_CDR(lst);
- }
- return scm_values (scm_list_2 (pre, lst));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_split_at_x, "split-at!", 2, 0, 0,
- (SCM lst, SCM n),
- "Return two values (multiple values), being a list of the\n"
- "elements before index @var{n} in @var{lst}, and a list of those\n"
- "after. @var{lst} is modified to form those values.")
-#define FUNC_NAME s_scm_srfi1_split_at
-{
- size_t nn;
- SCM upto = lst;
- SCM *loc = &lst;
-
- for (nn = scm_to_size_t (n); nn != 0; nn--)
- {
- SCM_VALIDATE_CONS (SCM_ARG1, upto);
-
- loc = SCM_CDRLOC (upto);
- upto = SCM_CDR (upto);
- }
-
- *loc = SCM_EOL;
- return scm_values (scm_list_2 (lst, upto));
-}
-#undef FUNC_NAME
-
-SCM
-scm_srfi1_take_x (SCM lst, SCM n)
-{
- CACHE_VAR (take_x, "take!");
- return scm_call_2 (take_x, lst, n);
-}
-
-SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0,
- (SCM lst, SCM n),
- "Return the a list containing the @var{n} last elements of\n"
- "@var{lst}.")
-#define FUNC_NAME s_scm_srfi1_take_right
-{
- SCM tail = scm_list_tail (lst, n);
- while (scm_is_pair (tail))
- {
- lst = SCM_CDR (lst);
- tail = SCM_CDR (tail);
- }
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
- return lst;
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_srfi1_take_while (SCM pred, SCM lst)
-{
- CACHE_VAR (take_while, "take-while");
- return scm_call_2 (take_while, pred, lst);
-}
-
-SCM
-scm_srfi1_take_while_x (SCM pred, SCM lst)
-{
- CACHE_VAR (take_while_x, "take-while!");
- return scm_call_2 (take_while_x, pred, lst);
-}
-
-SCM
-scm_srfi1_tenth (SCM lst)
-{
- CACHE_VAR (tenth, "tenth");
- return scm_call_1 (tenth, lst);
-}
-
-SCM
-scm_srfi1_xcons (SCM d, SCM a)
-{
- CACHE_VAR (xcons, "xcons");
- return scm_call_2 (xcons, d, a);
-}
-
-
-void
-scm_init_srfi_1 (void)
-{
- SCM the_root_module = scm_lookup_closure_module (SCM_BOOL_F);
-#ifndef SCM_MAGIC_SNARFER
-#include "srfi/srfi-1.x"
-#endif
- scm_c_extend_primitive_generic
- (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module, "map")),
- SCM_VARIABLE_REF (scm_c_lookup ("map")));
- scm_c_extend_primitive_generic
- (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module, "for-each")),
- SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
-}
-
-/* End of srfi-1.c. */