diff options
Diffstat (limited to 'libguile/srfi-1.c')
-rw-r--r-- | libguile/srfi-1.c | 1619 |
1 files changed, 1619 insertions, 0 deletions
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c new file mode 100644 index 000000000..96715dc0d --- /dev/null +++ b/libguile/srfi-1.c @@ -0,0 +1,1619 @@ +/* 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/_scm.h" +#include "libguile/eq.h" + +#include "libguile/validate.h" +#include "libguile/list.h" +#include "libguile/eval.h" +#include "libguile/srfi-1.h" + +#include <stdarg.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 wouldn'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 = ⪯ + + 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_register_srfi_1 (void) +{ + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_srfi_1", + (scm_t_extension_init_func)scm_init_srfi_1, NULL); +} + +void +scm_init_srfi_1 (void) +{ + SCM the_root_module = scm_lookup_closure_module (SCM_BOOL_F); +#ifndef SCM_MAGIC_SNARFER +#include "libguile/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. */ |