diff options
author | Andy Wingo <wingo@pobox.com> | 2010-09-12 23:18:54 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-09-12 23:29:11 +0200 |
commit | 37710f7e8f63f784de0343c1948e8afbbc10e395 (patch) | |
tree | 8d96cda7a538c82c3f981454392d799aafa5c1eb /srfi/srfi-1.c | |
parent | 4453f887ed6004126a73673f76853b30263209aa (diff) | |
download | guile-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.c | 1603 |
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 = ⪯ - - 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. */ |