summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--srfi/srfi-1.c130
-rw-r--r--srfi/srfi-1.h4
-rw-r--r--srfi/srfi-1.scm26
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)