diff options
-rw-r--r-- | srfi/srfi-1.c | 130 | ||||
-rw-r--r-- | srfi/srfi-1.h | 4 | ||||
-rw-r--r-- | srfi/srfi-1.scm | 26 |
3 files changed, 134 insertions, 26 deletions
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index 1adcba6dc..e93472967 100644 --- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -473,6 +473,29 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0, #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_find, "find", 2, 0, 0, (SCM pred, SCM lst), "Return the first element of @var{lst} which satisfies the\n" @@ -864,6 +887,63 @@ SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0, } #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_t_trampoline_1 pred_tramp; + + pred_tramp = scm_trampoline_1 (pred); + SCM_ASSERT (pred_tramp, 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 (pred_tramp (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_DEFINE (scm_srfi1_remove, "remove", 2, 0, 0, (SCM pred, SCM list), "Return a list containing all elements from @var{lst} which do\n" @@ -895,6 +975,56 @@ SCM_DEFINE (scm_srfi1_remove, "remove", 2, 0, 0, } #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_t_trampoline_1 call = scm_trampoline_1 (pred); + SCM walk; + SCM *prev; + SCM_ASSERT (call, pred, 1, FUNC_NAME); + SCM_VALIDATE_LIST (2, list); + + for (prev = &list, walk = list; + scm_is_pair (walk); + walk = SCM_CDR (walk)) + { + if (scm_is_false (call (pred, SCM_CAR (walk)))) + prev = SCM_CDRLOC (walk); + else + *prev = SCM_CDR (walk); + } + + return list; +} +#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 + + void scm_init_srfi_1 (void) { diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h index 636345d0a..017211cc0 100644 --- a/srfi/srfi-1.h +++ b/srfi/srfi-1.h @@ -37,6 +37,7 @@ 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_drop_right (SCM lst, SCM n); 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); @@ -46,7 +47,10 @@ SCM_SRFI1_API SCM scm_srfi1_for_each (SCM proc, SCM arg1, SCM args); SCM_SRFI1_API SCM scm_srfi1_member (SCM obj, SCM ls, SCM pred); SCM_SRFI1_API SCM scm_srfi1_assoc (SCM key, SCM alist, SCM pred); SCM_SRFI1_API SCM scm_srfi1_partition (SCM pred, SCM list); +SCM_SRFI1_API SCM scm_srfi1_partition_x (SCM pred, SCM list); SCM_SRFI1_API SCM scm_srfi1_remove (SCM pred, SCM list); +SCM_SRFI1_API SCM scm_srfi1_remove_x (SCM pred, SCM list); +SCM_SRFI1_API SCM scm_srfi1_take_right (SCM lst, SCM n); SCM_SRFI1_API void scm_init_srfi_1 (void); diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index aec63890f..2fedbab09 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -341,24 +341,6 @@ (define take list-head) (define drop list-tail) -(define (take-right flist i) - (let lp ((n i) (l flist)) - (if (<= n 0) - (let lp0 ((s flist) (l l)) - (if (null? l) - s - (lp0 (cdr s) (cdr l)))) - (lp (- n 1) (cdr l))))) - -(define (drop-right flist i) - (let lp ((n i) (l flist)) - (if (<= n 0) - (let lp0 ((s flist) (l l) (acc '())) - (if (null? l) - (reverse! acc) - (lp0 (cdr s) (cdr l) (cons (car s) acc)))) - (lp (- n 1) (cdr l))))) - (define (take! x i) (if (<= i 0) '() @@ -568,14 +550,6 @@ (lp (map1 cdr l) (cons res rl)) (lp (map1 cdr l) rl))))))) -;;; Filtering & partitioning - -(define (partition! pred list) - (partition pred list)) ; XXX:optimize - -(define (remove! pred list) - (filter! (lambda (x) (not (pred x))) list)) - ;;; Searching (define (take-while pred ls) |