[Guile-commits] 12/17: srfi-1 lset-difference!: move from C to Scheme

[Rob Browning]

rlb pushed a commit to branch main
in repository guile.

commit 945c97b14d4f07f3f70b72efff8a18625603035c
Author: Rob Browning <rlb@defaultvalue.org>
AuthorDate: Wed Jul 17 23:12:14 2024 -0500

    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 | 118 ++++++++++++++++++++-----------------------
 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