summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2010-09-02 00:03:07 +0200
committerLudovic Courtès <ludo@gnu.org>2010-09-02 00:03:07 +0200
commitdcde43869ae42996fee7071790789322e214d78e (patch)
tree8c2d1abe2715db32fa38f85ae9eab6f610c4527f
parent5335850dbf9f11e9bbef0c8f88f12b684885db19 (diff)
downloadguile-dcde43869ae42996fee7071790789322e214d78e.tar.gz
SRFI-1: Rewrite `drop-right!', `drop-while', `reduce', etc. in Scheme.
This partially reverts commit e9508fbb7df0b1ead007637f16d80cf831776307 (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.
-rw-r--r--benchmark-suite/benchmarks/srfi-1.bm9
-rw-r--r--module/srfi/srfi-1.scm127
-rw-r--r--srfi/srfi-1.c376
3 files changed, 176 insertions, 336 deletions
diff --git a/benchmark-suite/benchmarks/srfi-1.bm b/benchmark-suite/benchmarks/srfi-1.bm
index e07d3b95f..835608d41 100644
--- a/benchmark-suite/benchmarks/srfi-1.bm
+++ b/benchmark-suite/benchmarks/srfi-1.bm
@@ -36,3 +36,12 @@
(benchmark "small" 2000000
(fold (lambda (x y) y) #f %small-list)))
+
+
+(with-benchmark-prefix "drop-while"
+
+ (benchmark "big" 30
+ (drop-while (lambda (n) #t) %big-list))
+
+ (benchmark "small" 2000000
+ (drop-while (lambda (n) #t) %small-list)))
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 852729346..1e27d6f91 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -350,6 +350,30 @@ end-of-list checking in contexts where dotted lists are allowed."
(define take list-head)
(define drop list-tail)
+(define (take! lst i)
+ "Linear-update variant of `take'."
+ (if (= i 0)
+ '()
+ (let ((tail (drop lst (- i 1))))
+ (set-cdr! tail '())
+ lst)))
+
+(define (drop-right! lst i)
+ "Linear-update variant of `drop-right'."
+ (let ((tail (drop lst i)))
+ (if (null? tail)
+ '()
+ (let loop ((prev lst)
+ (tail (cdr tail)))
+ (if (null? tail)
+ (if (pair? prev)
+ (begin
+ (set-cdr! prev '())
+ lst)
+ lst)
+ (loop (cdr prev)
+ (cdr tail)))))))
+
(define (last pair)
"Return the last element of the non-empty, finite list PAIR."
(car (last-pair pair)))
@@ -441,6 +465,24 @@ that result. See the manual for details."
lis
(uf (g seed) (cons (f seed) lis)))))
+(define (reduce f ridentity lst)
+ "`reduce' is a variant of `fold', where the first call to F is on two
+elements from LST, rather than one element and a given initial value.
+If LST is empty, RIDENTITY is returned. If LST has just one element
+then that's the return value."
+ (if (null? lst)
+ ridentity
+ (fold f (car lst) (cdr lst))))
+
+(define (reduce-right f ridentity lst)
+ "`reduce-right' is a variant of `fold-right', where the first call to
+F is on two elements from LST, rather than one element and a given
+initial value. If LST is empty, RIDENTITY is returned. If LST
+has just one element then that's the return value."
+ (if (null? lst)
+ ridentity
+ (fold-right f (last lst) (drop-right lst 1))))
+
;; Internal helper procedure. Map `f' over the single list `ls'.
;;
@@ -470,8 +512,72 @@ that result. See the manual for details."
(apply f l)
(lp (map1 cdr l)))))))
+
;;; Searching
+(define (take-while pred ls)
+ "Return a new list which is the longest initial prefix of LS whose
+elements all satisfy the predicate PRED."
+ (cond ((null? ls) '())
+ ((not (pred (car ls))) '())
+ (else
+ (let ((result (list (car ls))))
+ (let lp ((ls (cdr ls)) (p result))
+ (cond ((null? ls) result)
+ ((not (pred (car ls))) result)
+ (else
+ (set-cdr! p (list (car ls)))
+ (lp (cdr ls) (cdr p)))))))))
+
+(define (take-while! pred lst)
+ "Linear-update variant of `take-while'."
+ (let loop ((prev #f)
+ (rest lst))
+ (cond ((null? rest)
+ lst)
+ ((pred (car rest))
+ (loop rest (cdr rest)))
+ (else
+ (if (pair? prev)
+ (begin
+ (set-cdr! prev '())
+ lst)
+ '())))))
+
+(define (drop-while pred lst)
+ "Drop the longest initial prefix of LST whose elements all satisfy the
+predicate PRED."
+ (let loop ((lst lst))
+ (cond ((null? lst)
+ '())
+ ((pred (car lst))
+ (loop (cdr lst)))
+ (else lst))))
+
+(define (span pred lst)
+ "Return two values, the longest initial prefix of LST whose elements
+all satisfy the predicate PRED, and the remainder of LST."
+ (let lp ((lst lst) (rl '()))
+ (if (and (not (null? lst))
+ (pred (car lst)))
+ (lp (cdr lst) (cons (car lst) rl))
+ (values (reverse! rl) lst))))
+
+(define (span! pred list)
+ "Linear-update variant of `span'."
+ (let loop ((prev #f)
+ (rest list))
+ (cond ((null? rest)
+ (values list '()))
+ ((pred (car rest))
+ (loop rest (cdr rest)))
+ (else
+ (if (pair? prev)
+ (begin
+ (set-cdr! prev '())
+ (values list rest))
+ (values '() list))))))
+
(define (break pred clist)
"Return two values, the longest initial prefix of LST whose elements
all fail the predicate PRED, and the remainder of LST."
@@ -587,6 +693,27 @@ CLIST1 ... CLISTN, that satisfies PRED."
(every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r))
(lp (car r) (cdr r)))))))
+;; It's not quite clear if duplicates among the `rest' elements are meant to
+;; be cast out. The spec says `=' is called as (= lstelem restelem),
+;; suggesting perhaps not, but the reference implementation shows the "list"
+;; at each stage as including those elements already added. The latter
+;; corresponds to what's described for lset-union, so that's what's done.
+;;
+(define (lset-adjoin = list . rest)
+ "Add to LIST any of the elements of REST not already in the list.
+These elements are `cons'ed onto the start of LIST (so the return shares
+a common tail with LIST), but the order they're added is unspecified.
+
+The given `=' procedure is used for comparing elements, called
+as `(@var{=} listelem elem)', i.e., the second argument is one of the
+given REST parameters."
+ (let lp ((l rest) (acc list))
+ (if (null? l)
+ acc
+ (if (member (car l) acc (lambda (x y) (= y x)))
+ (lp (cdr l) acc)
+ (lp (cdr l) (cons (car l) acc))))))
+
(define (lset-union = . rest)
(let ((acc '()))
(for-each (lambda (lst)
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index 02c580d97..b81c90544 100644
--- a/srfi/srfi-1.c
+++ b/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)