/* 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.
+ * Copyright (C) 1995-1997, 2000-2003, 2005, 2006, 2008-2011, 2013
+ * 2014 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
*/
-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)
{
#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"
"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
+#define FUNC_NAME s_scm_srfi1_concatenate_x
{
SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
return scm_append_x (lstlst);
SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
}
- count += scm_is_true (scm_apply (pred, args, SCM_EOL));
+ count += scm_is_true (scm_apply_0 (pred, args));
}
}
#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_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"
"circular.")
#define FUNC_NAME s_scm_srfi1_length_plus
{
- long len = scm_ilength (lst);
- return (len >= 0 ? SCM_I_MAKINUM (len) : SCM_BOOL_F);
+ size_t i = 0;
+ SCM tortoise = lst;
+ SCM hare = lst;
+
+ do
+ {
+ if (!scm_is_pair (hare))
+ {
+ if (SCM_NULL_OR_NIL_P (hare))
+ return scm_from_size_t (i);
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, lst,
+ "proper or circular list");
+ }
+ hare = SCM_CDR (hare);
+ i++;
+ if (!scm_is_pair (hare))
+ {
+ if (SCM_NULL_OR_NIL_P (hare))
+ return scm_from_size_t (i);
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, lst,
+ "proper or circular list");
+ }
+ 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 SCM_BOOL_F;
}
#undef FUNC_NAME
#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"
+ "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_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"
+ "Return two values: the list of elements satisfying @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")
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"
+ "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{lst}. The order in\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.")
#define FUNC_NAME s_scm_srfi1_remove
}
#undef FUNC_NAME
-
-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_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
-
\f
void
scm_register_srfi_1 (void)
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. */
HCoop / bpt / guile.git / blobdiff