mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
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.
This commit is contained in:
Rob Browning
parent
3eb6afe738
commit
945c97b14d
4 changed files with 71 additions and 115 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue