From 03d4a3b5df6c59f620b5576ef37794daa84ffae7 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 20 Jul 2024 15:53:00 -0500 Subject: [PATCH] srfi-1 remove: move from C to Scheme The Scheme implementation is an adapted version of the approach used by delete-duplicates, which allows sharing any common tail. * libguile/srfi-1.c (scm_srfi1_remove): delete. * libguile/srfi-1.h (scm_srfi1_remove): delete. * module/srfi/srfi-1.scm: add remove. --- libguile/srfi-1.c | 31 ---------------------------- libguile/srfi-1.h | 1 - module/srfi/srfi-1.scm | 47 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 47 insertions(+), 32 deletions(-) diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index bb7930cc0..2ea915e8f 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -772,37 +772,6 @@ SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_srfi1_remove, "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.") -#define FUNC_NAME s_scm_srfi1_remove -{ - SCM walk; - SCM *prev; - SCM res = SCM_EOL; - SCM_VALIDATE_PROC (SCM_ARG1, pred); - SCM_VALIDATE_LIST (2, list); - - for (prev = &res, walk = list; - scm_is_pair (walk); - walk = SCM_CDR (walk)) - { - if (scm_is_false (scm_call_1 (pred, SCM_CAR (walk)))) - { - *prev = scm_cons (SCM_CAR (walk), SCM_EOL); - prev = SCM_CDRLOC (*prev); - } - } - - return res; -} -#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" diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h index 20cb478b4..61d479864 100644 --- a/libguile/srfi-1.h +++ b/libguile/srfi-1.h @@ -37,7 +37,6 @@ SCM_INTERNAL SCM scm_srfi1_length_plus (SCM lst); SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest); SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list); SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list); -SCM_INTERNAL SCM scm_srfi1_remove (SCM pred, SCM list); SCM_INTERNAL SCM scm_srfi1_remove_x (SCM pred, SCM list); SCM_INTERNAL void scm_register_srfi_1 (void); diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index 89090af89..313227ad4 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -735,6 +735,53 @@ the list returned." (apply f l) (lp (map cdr l))))))) + +;;; Filtering & partitioning + +(define (list-prefix-and-tail lst stop) + (when (eq? lst stop) + (error "Prefix cannot be empty")) + (let ((rl (list (car lst)))) + (let lp ((lst (cdr lst)) (tail rl)) + (if (eq? lst stop) + (values rl tail) + (let ((new-tail (list (car lst)))) + (set-cdr! tail new-tail) + (lp (cdr lst) new-tail)))))) + +(define (remove pred lst) + "Return a list containing all elements from @var{list} which do not +satisfy the predicate @var{pred}. The elements in the result list have +the same order as in @var{list}. The order in which @var{pred} is +applied to the list elements is not specified, and the result may share +a common tail with @{list}." + ;; Traverse the lst, keeping the tail of it, in which we have yet to + ;; find a duplicate, in last-kept. Share that tail with the result + ;; (possibly the entire original lst). Build the result by + ;; destructively appending unique values to its tail, and henever we + ;; find a duplicate, copy the pending last-kept prefix into the result + ;; and move last-kept forward to the current position in lst. + (if (null? lst) + lst + (let ((result (list #f))) + (let lp ((lst lst) + (last-kept lst) + (tail result)) + (if (null? lst) + (begin + (set-cdr! tail last-kept) + (cdr result)) + (let ((item (car lst))) + (if (pred item) + (if (eq? last-kept lst) + (lp (cdr lst) (cdr lst) tail) + (call-with-values + (lambda () (list-prefix-and-tail last-kept lst)) + (lambda (prefix new-tail) + (set-cdr! tail prefix) + (lp (cdr lst) (cdr lst) new-tail)))) + (lp (cdr lst) last-kept tail)))))))) + ;;; Searching