summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/srfi-1.c59
-rw-r--r--libguile/srfi-1.h1
-rw-r--r--module/srfi/srfi-1.scm24
-rw-r--r--test-suite/tests/srfi-1.test118
4 files changed, 79 insertions, 123 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)))
-
-;;
-;; lset-difference!
-;;
-
-(with-test-prefix "lset-difference!"
-
- (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 "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? '() (lset-difference! = '())))
- (pass-if (equal? '(1) (lset-difference! = (list 1))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 1 2))))
-
- (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) (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))))
-
- (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)))))
+ (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))
+
+ (pass-if (equal? '() (diff = '())))
+ (pass-if (equal? '(1) (diff = (list 1))))
+ (pass-if (equal? '(1 2) (diff = (list 1 2))))
+
+ (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 (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 (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? '(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? '(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)))))
+
+ (with-test-prefix "lset-difference"
+ (test-shared-behavior lset-difference))
+
+ (with-test-prefix "lset-difference!"
+ (test-shared-behavior lset-difference!)))
;;
;; lset-diff+intersection