mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-08 10:50:21 +02:00
SRFI-1: Rewrite drop-right!', drop-while', `reduce', etc. in Scheme.
This partially reverts commit e9508fbb7d
(May 3 2005).
* module/srfi/srfi-1.scm (take!, drop-right!, reduce, reduce-right,
take-while, take-while!, drop-while, span, span!, lset-adjoin): New
procedures.
* srfi/srfi-1.c (scm_srfi1_drop_right_x, scm_srfi1_drop_while,
scm_srfi1_lset_adjoin, scm_srfi1_reduce, scm_srfi1_reduce_right,
scm_srfi1_span, scm_srfi1_span_x, scm_srfi1_take_x,
scm_srfi1_take_while, scm_srfi1_take_while_x): Rewrite as
proxies to the corresponding Scheme procedures.
* benchmark-suite/benchmarks/srfi-1.bm ("drop-while"): New benchmark
prefix.
This commit is contained in:
Ludovic Courtès
parent
5335850dbf
commit
dcde43869a
3 changed files with 176 additions and 336 deletions
376
srfi/srfi-1.c
376
srfi/srfi-1.c
|
|
@ -683,52 +683,19 @@ SCM_DEFINE (scm_srfi1_drop_right, "drop-right", 2, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_srfi1_drop_right_x, "drop-right!", 2, 0, 0,
|
||||
(SCM lst, SCM n),
|
||||
"Return the a list containing the @var{n} last elements of\n"
|
||||
"@var{lst}. @var{lst} may be modified to build the return.")
|
||||
#define FUNC_NAME s_scm_srfi1_drop_right_x
|
||||
SCM
|
||||
scm_srfi1_drop_right_x (SCM lst, SCM n)
|
||||
{
|
||||
SCM tail, *p;
|
||||
|
||||
if (scm_is_eq (n, SCM_INUM0))
|
||||
return lst;
|
||||
|
||||
tail = scm_list_tail (lst, n);
|
||||
p = &lst;
|
||||
|
||||
/* p and tail work along the list, p being the cdrloc of the cell n steps
|
||||
behind tail */
|
||||
for ( ; scm_is_pair (tail); tail = SCM_CDR (tail))
|
||||
p = SCM_CDRLOC (*p);
|
||||
|
||||
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
|
||||
|
||||
*p = SCM_EOL;
|
||||
return lst;
|
||||
CACHE_VAR (drop_right_x, "drop-right!");
|
||||
return scm_call_2 (drop_right_x, lst, n);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_srfi1_drop_while, "drop-while", 2, 0, 0,
|
||||
(SCM pred, SCM lst),
|
||||
"Drop the longest initial prefix of @var{lst} whose elements all\n"
|
||||
"satisfy the predicate @var{pred}.")
|
||||
#define FUNC_NAME s_scm_srfi1_drop_while
|
||||
SCM
|
||||
scm_srfi1_drop_while (SCM pred, SCM lst)
|
||||
{
|
||||
SCM_VALIDATE_PROC (SCM_ARG1, pred);
|
||||
|
||||
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
|
||||
if (scm_is_false (scm_call_1 (pred, SCM_CAR (lst))))
|
||||
goto done;
|
||||
|
||||
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
|
||||
done:
|
||||
return lst;
|
||||
CACHE_VAR (drop_while, "drop-while");
|
||||
return scm_call_2 (drop_while, pred, lst);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM
|
||||
scm_srfi1_eighth (SCM lst)
|
||||
|
|
@ -966,55 +933,12 @@ scm_srfi1_list_tabulate (SCM n, SCM proc)
|
|||
return scm_call_2 (list_tabulate, n, proc);
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_srfi1_lset_adjoin, "lset-adjoin", 2, 0, 1,
|
||||
(SCM equal, SCM lst, SCM rest),
|
||||
"Add to @var{list} any of the given @var{elem}s not already in\n"
|
||||
"the list. @var{elem}s are @code{cons}ed onto the start of\n"
|
||||
"@var{list} (so the return shares a common tail with\n"
|
||||
"@var{list}), but the order they're added is unspecified.\n"
|
||||
"\n"
|
||||
"The given @var{=} procedure is used for comparing elements,\n"
|
||||
"called as @code{(@var{=} listelem elem)}, ie.@: the second\n"
|
||||
"argument is one of the given @var{elem} parameters.\n"
|
||||
"\n"
|
||||
"@example\n"
|
||||
"(lset-adjoin eqv? '(1 2 3) 4 1 5) @result{} (5 4 1 2 3)\n"
|
||||
"@end example")
|
||||
#define FUNC_NAME s_scm_srfi1_lset_adjoin
|
||||
SCM
|
||||
scm_srfi1_lset_adjoin (SCM equal, SCM lst, SCM rest)
|
||||
{
|
||||
SCM l, elem;
|
||||
|
||||
SCM_VALIDATE_PROC (SCM_ARG1, equal);
|
||||
SCM_VALIDATE_REST_ARGUMENT (rest);
|
||||
|
||||
/* It's not clear if duplicates among the `rest' elements are meant to be
|
||||
cast out. The spec says `=' is called as (= list-elem rest-elem),
|
||||
suggesting perhaps not, but the reference implementation shows the
|
||||
"list" at each stage as including those "rest" elements already added.
|
||||
The latter corresponds to what's described for lset-union, so that's
|
||||
what's done here. */
|
||||
|
||||
for ( ; scm_is_pair (rest); rest = SCM_CDR (rest))
|
||||
{
|
||||
elem = SCM_CAR (rest);
|
||||
|
||||
for (l = lst; scm_is_pair (l); l = SCM_CDR (l))
|
||||
if (scm_is_true (scm_call_2 (equal, SCM_CAR (l), elem)))
|
||||
goto next_elem; /* elem already in lst, don't add */
|
||||
|
||||
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(l), lst, SCM_ARG2, FUNC_NAME, "list");
|
||||
|
||||
/* elem is not equal to anything already in lst, add it */
|
||||
lst = scm_cons (elem, lst);
|
||||
|
||||
next_elem:
|
||||
;
|
||||
}
|
||||
|
||||
return lst;
|
||||
CACHE_VAR (lset_adjoin, "lset-adjoin");
|
||||
return scm_apply_1 (lset_adjoin, lst, rest);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1,
|
||||
(SCM equal, SCM lst, SCM rest),
|
||||
|
|
@ -1454,126 +1378,19 @@ SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_srfi1_reduce, "reduce", 3, 0, 0,
|
||||
(SCM proc, SCM def, SCM lst),
|
||||
"@code{reduce} is a variant of @code{fold}, where the first call\n"
|
||||
"to @var{proc} is on two elements from @var{lst}, rather than\n"
|
||||
"one element and a given initial value.\n"
|
||||
"\n"
|
||||
"If @var{lst} is empty, @code{reduce} returns @var{def} (this is\n"
|
||||
"the only use for @var{def}). If @var{lst} has just one element\n"
|
||||
"then that's the return value. Otherwise @var{proc} is called\n"
|
||||
"on the elements of @var{lst}.\n"
|
||||
"\n"
|
||||
"Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
|
||||
"@var{previous})}, where @var{elem} is from @var{lst} (the\n"
|
||||
"second and subsequent elements of @var{lst}), and\n"
|
||||
"@var{previous} is the return from the previous call to\n"
|
||||
"@var{proc}. The first element of @var{lst} is the\n"
|
||||
"@var{previous} for the first call to @var{proc}.\n"
|
||||
"\n"
|
||||
"For example, the following adds a list of numbers, the calls\n"
|
||||
"made to @code{+} are shown. (Of course @code{+} accepts\n"
|
||||
"multiple arguments and can add a list directly, with\n"
|
||||
"@code{apply}.)\n"
|
||||
"\n"
|
||||
"@example\n"
|
||||
"(reduce + 0 '(5 6 7)) @result{} 18\n"
|
||||
"\n"
|
||||
"(+ 6 5) @result{} 11\n"
|
||||
"(+ 7 11) @result{} 18\n"
|
||||
"@end example\n"
|
||||
"\n"
|
||||
"@code{reduce} can be used instead of @code{fold} where the\n"
|
||||
"@var{init} value is an ``identity'', meaning a value which\n"
|
||||
"under @var{proc} doesn't change the result, in this case 0 is\n"
|
||||
"an identity since @code{(+ 5 0)} is just 5. @code{reduce}\n"
|
||||
"avoids that unnecessary call.")
|
||||
#define FUNC_NAME s_scm_srfi1_reduce
|
||||
SCM
|
||||
scm_srfi1_reduce (SCM proc, SCM def, SCM lst)
|
||||
{
|
||||
SCM ret;
|
||||
SCM_VALIDATE_PROC (SCM_ARG1, proc);
|
||||
ret = def; /* if lst is empty */
|
||||
if (scm_is_pair (lst))
|
||||
{
|
||||
ret = SCM_CAR (lst); /* if lst has one element */
|
||||
|
||||
for (lst = SCM_CDR (lst); scm_is_pair (lst); lst = SCM_CDR (lst))
|
||||
ret = scm_call_2 (proc, SCM_CAR (lst), ret);
|
||||
}
|
||||
|
||||
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG3, FUNC_NAME, "list");
|
||||
return ret;
|
||||
CACHE_VAR (reduce, "reduce");
|
||||
return scm_call_3 (reduce, proc, def, lst);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_srfi1_reduce_right, "reduce-right", 3, 0, 0,
|
||||
(SCM proc, SCM def, SCM lst),
|
||||
"@code{reduce-right} is a variant of @code{fold-right}, where\n"
|
||||
"the first call to @var{proc} is on two elements from @var{lst},\n"
|
||||
"rather than one element and a given initial value.\n"
|
||||
"\n"
|
||||
"If @var{lst} is empty, @code{reduce-right} returns @var{def}\n"
|
||||
"(this is the only use for @var{def}). If @var{lst} has just\n"
|
||||
"one element then that's the return value. Otherwise @var{proc}\n"
|
||||
"is called on the elements of @var{lst}.\n"
|
||||
"\n"
|
||||
"Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
|
||||
"@var{previous})}, where @var{elem} is from @var{lst} (the\n"
|
||||
"second last and then working back to the first element of\n"
|
||||
"@var{lst}), and @var{previous} is the return from the previous\n"
|
||||
"call to @var{proc}. The last element of @var{lst} is the\n"
|
||||
"@var{previous} for the first call to @var{proc}.\n"
|
||||
"\n"
|
||||
"For example, the following adds a list of numbers, the calls\n"
|
||||
"made to @code{+} are shown. (Of course @code{+} accepts\n"
|
||||
"multiple arguments and can add a list directly, with\n"
|
||||
"@code{apply}.)\n"
|
||||
"\n"
|
||||
"@example\n"
|
||||
"(reduce-right + 0 '(5 6 7)) @result{} 18\n"
|
||||
"\n"
|
||||
"(+ 6 7) @result{} 13\n"
|
||||
"(+ 5 13) @result{} 18\n"
|
||||
"@end example\n"
|
||||
"\n"
|
||||
"@code{reduce-right} can be used instead of @code{fold-right}\n"
|
||||
"where the @var{init} value is an ``identity'', meaning a value\n"
|
||||
"which under @var{proc} doesn't change the result, in this case\n"
|
||||
"0 is an identity since @code{(+ 7 0)} is just 5.\n"
|
||||
"@code{reduce-right} avoids that unnecessary call.\n"
|
||||
"\n"
|
||||
"@code{reduce} should be preferred over @code{reduce-right} if\n"
|
||||
"the order of processing doesn't matter, or can be arranged\n"
|
||||
"either way, since @code{reduce} is a little more efficient.")
|
||||
#define FUNC_NAME s_scm_srfi1_reduce_right
|
||||
SCM
|
||||
scm_srfi1_reduce_right (SCM proc, SCM def, SCM lst)
|
||||
{
|
||||
/* To work backwards across a list requires either repeatedly traversing
|
||||
to get each previous element, or using some memory for a reversed or
|
||||
random-access form. Repeated traversal might not be too terrible, but
|
||||
is of course quadratic complexity and hence to be avoided in case LST
|
||||
is long. A vector is preferred over a reversed list since it's more
|
||||
compact and is less work for the gc to collect. */
|
||||
|
||||
SCM vec, ret;
|
||||
ssize_t len, i;
|
||||
SCM_VALIDATE_PROC (SCM_ARG1, proc);
|
||||
if (SCM_NULL_OR_NIL_P (lst))
|
||||
return def;
|
||||
|
||||
vec = scm_vector (lst);
|
||||
len = SCM_SIMPLE_VECTOR_LENGTH (vec);
|
||||
|
||||
ret = SCM_SIMPLE_VECTOR_REF (vec, len-1);
|
||||
for (i = len-2; i >= 0; i--)
|
||||
ret = scm_call_2 (proc, SCM_SIMPLE_VECTOR_REF (vec, i), ret);
|
||||
|
||||
return ret;
|
||||
CACHE_VAR (reduce_right, "reduce-right");
|
||||
return scm_call_3 (reduce_right, proc, def, lst);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_srfi1_remove, "remove", 2, 0, 0,
|
||||
(SCM pred, SCM list),
|
||||
|
|
@ -1650,67 +1467,19 @@ scm_srfi1_sixth (SCM lst)
|
|||
return scm_call_1 (sixth, lst);
|
||||
}
|
||||
|
||||
|
||||
SCM_DEFINE (scm_srfi1_span, "span", 2, 0, 0,
|
||||
(SCM pred, SCM lst),
|
||||
"Return two values, the longest initial prefix of @var{lst}\n"
|
||||
"whose elements all satisfy the predicate @var{pred}, and the\n"
|
||||
"remainder of @var{lst}.")
|
||||
#define FUNC_NAME s_scm_srfi1_span
|
||||
SCM
|
||||
scm_srfi1_span (SCM pred, SCM lst)
|
||||
{
|
||||
SCM ret, *p;
|
||||
|
||||
SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
|
||||
|
||||
ret = SCM_EOL;
|
||||
p = &ret;
|
||||
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
|
||||
{
|
||||
SCM elem = SCM_CAR (lst);
|
||||
if (scm_is_false (scm_call_1 (pred, elem)))
|
||||
goto done;
|
||||
|
||||
/* want this elem, tack it onto the end of ret */
|
||||
*p = scm_cons (elem, SCM_EOL);
|
||||
p = SCM_CDRLOC (*p);
|
||||
}
|
||||
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
|
||||
|
||||
done:
|
||||
return scm_values (scm_list_2 (ret, lst));
|
||||
CACHE_VAR (span, "span");
|
||||
return scm_call_2 (span, pred, lst);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_srfi1_span_x, "span!", 2, 0, 0,
|
||||
(SCM pred, SCM lst),
|
||||
"Return two values, the longest initial prefix of @var{lst}\n"
|
||||
"whose elements all satisfy the predicate @var{pred}, and the\n"
|
||||
"remainder of @var{lst}. @var{lst} may be modified to form the\n"
|
||||
"return.")
|
||||
#define FUNC_NAME s_scm_srfi1_span_x
|
||||
SCM
|
||||
scm_srfi1_span_x (SCM pred, SCM lst)
|
||||
{
|
||||
SCM upto, *p;
|
||||
|
||||
SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
|
||||
|
||||
p = &lst;
|
||||
for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
|
||||
{
|
||||
if (scm_is_false (scm_call_1 (pred, SCM_CAR (upto))))
|
||||
goto done;
|
||||
|
||||
/* want this element */
|
||||
p = SCM_CDRLOC (upto);
|
||||
}
|
||||
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto), lst, SCM_ARG2, FUNC_NAME, "list");
|
||||
|
||||
done:
|
||||
*p = SCM_EOL;
|
||||
return scm_values (scm_list_2 (lst, upto));
|
||||
CACHE_VAR (span_x, "span!");
|
||||
return scm_call_2 (span_x, pred, lst);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_srfi1_split_at, "split-at", 2, 0, 0,
|
||||
(SCM lst, SCM n),
|
||||
|
|
@ -1762,33 +1531,12 @@ SCM_DEFINE (scm_srfi1_split_at_x, "split-at!", 2, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_srfi1_take_x, "take!", 2, 0, 0,
|
||||
(SCM lst, SCM n),
|
||||
"Return a list containing the first @var{n} elements of\n"
|
||||
"@var{lst}.")
|
||||
#define FUNC_NAME s_scm_srfi1_take_x
|
||||
SCM
|
||||
scm_srfi1_take_x (SCM lst, SCM n)
|
||||
{
|
||||
long nn;
|
||||
SCM pos;
|
||||
|
||||
nn = scm_to_signed_integer (n, 0, LONG_MAX);
|
||||
if (nn == 0)
|
||||
return SCM_EOL;
|
||||
|
||||
pos = scm_list_tail (lst, scm_from_long (nn - 1));
|
||||
|
||||
/* Must have at least one cell left, mustn't have reached the end of an
|
||||
n-1 element list. SCM_VALIDATE_CONS here gives the same error as
|
||||
scm_list_tail does on say an n-2 element list, though perhaps a range
|
||||
error would make more sense (for both). */
|
||||
SCM_VALIDATE_CONS (SCM_ARG1, pos);
|
||||
|
||||
SCM_SETCDR (pos, SCM_EOL);
|
||||
return lst;
|
||||
CACHE_VAR (take_x, "take!");
|
||||
return scm_call_2 (take_x, lst, n);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0,
|
||||
(SCM lst, SCM n),
|
||||
|
|
@ -1808,63 +1556,19 @@ SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0,
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_srfi1_take_while, "take-while", 2, 0, 0,
|
||||
(SCM pred, SCM lst),
|
||||
"Return a new list which is the longest initial prefix of\n"
|
||||
"@var{lst} whose elements all satisfy the predicate @var{pred}.")
|
||||
#define FUNC_NAME s_scm_srfi1_take_while
|
||||
SCM
|
||||
scm_srfi1_take_while (SCM pred, SCM lst)
|
||||
{
|
||||
SCM ret, *p;
|
||||
|
||||
SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
|
||||
|
||||
ret = SCM_EOL;
|
||||
p = &ret;
|
||||
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
|
||||
{
|
||||
SCM elem = SCM_CAR (lst);
|
||||
if (scm_is_false (scm_call_1 (pred, elem)))
|
||||
goto done;
|
||||
|
||||
/* want this elem, tack it onto the end of ret */
|
||||
*p = scm_cons (elem, SCM_EOL);
|
||||
p = SCM_CDRLOC (*p);
|
||||
}
|
||||
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
|
||||
|
||||
done:
|
||||
return ret;
|
||||
CACHE_VAR (take_while, "take-while");
|
||||
return scm_call_2 (take_while, pred, lst);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_srfi1_take_while_x, "take-while!", 2, 0, 0,
|
||||
(SCM pred, SCM lst),
|
||||
"Return the longest initial prefix of @var{lst} whose elements\n"
|
||||
"all satisfy the predicate @var{pred}. @var{lst} may be\n"
|
||||
"modified to form the return.")
|
||||
#define FUNC_NAME s_scm_srfi1_take_while_x
|
||||
SCM
|
||||
scm_srfi1_take_while_x (SCM pred, SCM lst)
|
||||
{
|
||||
SCM upto, *p;
|
||||
|
||||
SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
|
||||
|
||||
p = &lst;
|
||||
for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
|
||||
{
|
||||
if (scm_is_false (scm_call_1 (pred, SCM_CAR (upto))))
|
||||
goto done;
|
||||
|
||||
/* want this element */
|
||||
p = SCM_CDRLOC (upto);
|
||||
}
|
||||
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto), lst, SCM_ARG2, FUNC_NAME, "list");
|
||||
|
||||
done:
|
||||
*p = SCM_EOL;
|
||||
return lst;
|
||||
CACHE_VAR (take_while_x, "take-while!");
|
||||
return scm_call_2 (take_while_x, pred, lst);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM
|
||||
scm_srfi1_tenth (SCM lst)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue