From 945c97b14d4f07f3f70b72efff8a18625603035c Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 17 Jul 2024 23:12:14 -0500 Subject: [PATCH] srfi-1 lset-difference!: move from C to Scheme * libguile/srfi-1.c (scm_srfi1_lset-difference_x): delete. * libguile/srfi-1.h (scm_srfi1_lset-difference_x): delete. * module/srfi/srfi-1.scm: add lset-difference!. * test-suite/tests/srfi-1.test: extend lset-difference! tests to cover lset-difference. --- libguile/srfi-1.c | 59 -------------------- libguile/srfi-1.h | 1 - module/srfi/srfi-1.scm | 24 +++++++++ test-suite/tests/srfi-1.test | 102 ++++++++++++++++------------------- 4 files changed, 71 insertions(+), 115 deletions(-) diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index 64b4f46ee..56e12296b 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -272,65 +272,6 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1, - (SCM equal, SCM lst, SCM rest), - "Return @var{lst} with any elements in the lists in @var{rest}\n" - "removed (ie.@: subtracted). For only one @var{lst} argument,\n" - "just that list is returned.\n" - "\n" - "The given @var{equal} procedure is used for comparing elements,\n" - "called as @code{(@var{equal} elem1 elemN)}. The first argument\n" - "is from @var{lst} and the second from one of the subsequent\n" - "lists. But exactly which calls are made and in what order is\n" - "unspecified.\n" - "\n" - "@example\n" - "(lset-difference! eqv? (list 'x 'y)) @result{} (x y)\n" - "(lset-difference! eqv? (list 1 2 3) '(3 1)) @result{} (2)\n" - "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n" - "@end example\n" - "\n" - "@code{lset-difference!} may modify @var{lst} to form its\n" - "result.") -#define FUNC_NAME s_scm_srfi1_lset_difference_x -{ - SCM ret, *pos, elem, r, b; - int argnum; - - SCM_VALIDATE_PROC (SCM_ARG1, equal); - SCM_VALIDATE_REST_ARGUMENT (rest); - - ret = SCM_EOL; - pos = &ret; - for ( ; scm_is_pair (lst); lst = SCM_CDR (lst)) - { - elem = SCM_CAR (lst); - - for (r = rest, argnum = SCM_ARG3; - scm_is_pair (r); - r = SCM_CDR (r), argnum++) - { - for (b = SCM_CAR (r); scm_is_pair (b); b = SCM_CDR (b)) - if (scm_is_true (scm_call_2 (equal, elem, SCM_CAR (b)))) - goto next_elem; /* equal to elem, so drop that elem */ - - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b), b, argnum, FUNC_NAME,"list"); - } - - /* elem not equal to anything in later lists, so keep it */ - *pos = lst; - pos = SCM_CDRLOC (lst); - - next_elem: - ; - } - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list"); - - *pos = SCM_EOL; - return ret; -} -#undef FUNC_NAME - void scm_register_srfi_1 (void) diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h index c0f8f8866..1e906424d 100644 --- a/libguile/srfi-1.h +++ b/libguile/srfi-1.h @@ -26,7 +26,6 @@ SCM_INTERNAL SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred); SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred); -SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest); SCM_INTERNAL void scm_register_srfi_1 (void); SCM_INTERNAL void scm_init_srfi_1 (void); diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index 49ee46e40..01413c963 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -1350,6 +1350,30 @@ given REST parameters." (check-arg procedure? = lset-intersection!) (apply lset-intersection = list1 rest)) ; XXX:optimize +(define (lset-difference! = lset . removals) + "Return @var{lst} with any elements in the lists in @var{removals} +removed (ie.@: subtracted). For only one @var{lst} argument, just that +list is returned. + +The given @var{equal} procedure is used for comparing elements, called +as @code{(@var{equal} elem1 elemN)}. The first argument is from +@var{lst} and the second from one of the subsequent lists. But exactly +which calls are made and in what order is unspecified. + +@example +(lset-difference! eqv? (list 'x 'y)) @result{} (x y) +(lset-difference! eqv? (list 1 2 3) '(3 1)) @result{} (2) +(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1) +@end example + +@code{lset-difference!} may modify @var{lst} to form its result." + (check-arg procedure? = lset-intersection!) + (cond + ((null? lset) lset) + ((null? removals) lset) + (else (remove! (lambda (x) (any (lambda (s) (member x s =)) removals)) + lset)))) + (define (lset-xor! = . rest) (check-arg procedure? = lset-xor!) (apply lset-xor = rest)) ; XXX:optimize diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index a1ced0fb5..558934df4 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -1769,72 +1769,64 @@ (equal? '(1 2) (lset-adjoin = '(2) 1 1)))) ;; -;; lset-difference +;; lset-difference and lset-difference! ;; -(with-test-prefix "lset-difference" +(begin + (define (test-shared-behavior diff) + (pass-if-exception "proc - num" exception:wrong-type-arg + (diff 123 '(4))) + (pass-if-exception "proc - list" exception:wrong-type-arg + (diff (list 1 2 3) '(4))) - (pass-if "called arg order" - (let ((good #f)) - (lset-difference (lambda (x y) - (set! good (and (= x 1) (= y 2))) - (= x y)) - '(1) '(2)) - good))) + (pass-if "called arg order" + (let ((good #f)) + (diff (lambda (x y) + (set! good (and (= x 1) (= y 2))) + (= x y)) + (list 1) (list 2)) + good)) -;; -;; lset-difference! -;; + (pass-if (equal? '() (diff = '()))) + (pass-if (equal? '(1) (diff = (list 1)))) + (pass-if (equal? '(1 2) (diff = (list 1 2)))) -(with-test-prefix "lset-difference!" + (pass-if (equal? '() (diff = (list ) '(3)))) + (pass-if (equal? '() (diff = (list 3) '(3)))) + (pass-if (equal? '(1) (diff = (list 1 3) '(3)))) + (pass-if (equal? '(1) (diff = (list 3 1) '(3)))) + (pass-if (equal? '(1) (diff = (list 1 3 3) '(3)))) + (pass-if (equal? '(1) (diff = (list 3 1 3) '(3)))) + (pass-if (equal? '(1) (diff = (list 3 3 1) '(3)))) - (pass-if-exception "proc - num" exception:wrong-type-arg - (lset-difference! 123 '(4))) - (pass-if-exception "proc - list" exception:wrong-type-arg - (lset-difference! (list 1 2 3) '(4))) + (pass-if (equal? '(1) (diff = (list 1 2 3) '(2 3)))) + (pass-if (equal? '(1) (diff = (list 1 2 3) '(3 2)))) + (pass-if (equal? '(1) (diff = (list 1 2 3) '(3) '(2)))) + (pass-if (equal? '(1) (diff = (list 1 2 3) '(2) '(3)))) + (pass-if (equal? '(1) (diff = (list 1 2 3) '(2) '(2 3)))) + (pass-if (equal? '(1) (diff = (list 1 2 3) '(2) '(3 2)))) - (pass-if "called arg order" - (let ((good #f)) - (lset-difference! (lambda (x y) - (set! good (and (= x 1) (= y 2))) - (= x y)) - (list 1) (list 2)) - good)) + (pass-if (equal? '(1 2) (diff = (list 1 2 3) '(3) '(3)))) + (pass-if (equal? '(1 2) (diff = (list 1 3 2) '(3) '(3)))) + (pass-if (equal? '(1 2) (diff = (list 3 1 2) '(3) '(3)))) - (pass-if (equal? '() (lset-difference! = '()))) - (pass-if (equal? '(1) (lset-difference! = (list 1)))) - (pass-if (equal? '(1 2) (lset-difference! = (list 1 2)))) + (pass-if (equal? '(1 2 3) (diff = (list 1 2 3 4) '(4)))) + (pass-if (equal? '(1 2 3) (diff = (list 1 2 4 3) '(4)))) + (pass-if (equal? '(1 2 3) (diff = (list 1 4 2 3) '(4)))) + (pass-if (equal? '(1 2 3) (diff = (list 4 1 2 3) '(4)))) - (pass-if (equal? '() (lset-difference! = (list ) '(3)))) - (pass-if (equal? '() (lset-difference! = (list 3) '(3)))) - (pass-if (equal? '(1) (lset-difference! = (list 1 3) '(3)))) - (pass-if (equal? '(1) (lset-difference! = (list 3 1) '(3)))) - (pass-if (equal? '(1) (lset-difference! = (list 1 3 3) '(3)))) - (pass-if (equal? '(1) (lset-difference! = (list 3 1 3) '(3)))) - (pass-if (equal? '(1) (lset-difference! = (list 3 3 1) '(3)))) + (pass-if (equal? '(1 2) (diff = (list 1 2 3 4) '(4) '(3)))) + (pass-if (equal? '(1 2) (diff = (list 1 3 2 4) '(4) '(3)))) + (pass-if (equal? '(1 2) (diff = (list 3 1 2 4) '(4) '(3)))) + (pass-if (equal? '(1 2) (diff = (list 1 3 4 2) '(4) '(3)))) + (pass-if (equal? '(1 2) (diff = (list 3 1 4 2) '(4) '(3)))) + (pass-if (equal? '(1 2) (diff = (list 3 4 1 2) '(4) '(3))))) - (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2 3)))) - (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3 2)))) - (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3) '(2)))) - (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3)))) - (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(2 3)))) - (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3 2)))) + (with-test-prefix "lset-difference" + (test-shared-behavior lset-difference)) - (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3) '(3) '(3)))) - (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2) '(3) '(3)))) - (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2) '(3) '(3)))) - - (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 3 4) '(4)))) - (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 4 3) '(4)))) - (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 4 2 3) '(4)))) - (pass-if (equal? '(1 2 3) (lset-difference! = (list 4 1 2 3) '(4)))) - - (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3 4) '(4) '(3)))) - (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2 4) '(4) '(3)))) - (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2 4) '(4) '(3)))) - (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 4 2) '(4) '(3)))) - (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 4 2) '(4) '(3)))) - (pass-if (equal? '(1 2) (lset-difference! = (list 3 4 1 2) '(4) '(3))))) + (with-test-prefix "lset-difference!" + (test-shared-behavior lset-difference!))) ;; ;; lset-diff+intersection