mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 16:20:17 +02:00
Code Activity

(find, find-tail): Rewrite in C.

Browse source
This commit is contained in:
Kevin Ryde 2005-03-13 22:49:28 +00:00
parent 6851314445
commit 5df2ac97e9
3 changed files with 45 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

43
srfi/srfi-1.c
View file

@ -473,6 +473,49 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0,
#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_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
{
SCM elem = SCM_CAR (lst);
if (scm_is_true (pred_tramp (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_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
if (scm_is_true (pred_tramp (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_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"

2
srfi/srfi-1.h
View file

@ -37,6 +37,8 @@ SCM_SRFI1_API SCM scm_srfi1_delete (SCM x, SCM lst, SCM pred);
SCM_SRFI1_API SCM scm_srfi1_delete_x (SCM x, SCM lst, SCM pred);
SCM_SRFI1_API SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred);
SCM_SRFI1_API SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred);
SCM_SRFI1_API SCM scm_srfi1_find (SCM pred, SCM lst);
SCM_SRFI1_API SCM scm_srfi1_find_tail (SCM pred, SCM lst);
SCM_SRFI1_API SCM scm_srfi1_length_plus (SCM lst);
SCM_SRFI1_API SCM scm_srfi1_list_copy (SCM lst);
SCM_SRFI1_API SCM scm_srfi1_map (SCM proc, SCM arg1, SCM args);

14
srfi/srfi-1.scm
View file

@ -578,20 +578,6 @@
;;; Searching
(define (find pred clist)
(if (null? clist)
#f
(if (pred (car clist))
(car clist)
(find pred (cdr clist)))))
(define (find-tail pred clist)
(if (null? clist)
#f
(if (pred (car clist))
clist
(find-tail pred (cdr clist)))))
(define (take-while pred ls)
(cond ((null? ls) '())
((not (pred (car ls))) '())