Make sure lset-adjoin removes markings on the adjoined elementsHEADmaster

Add a test to ensure this won't happen again.

2 files changed, 58 insertions, 15 deletions

diff --git a/slsets.scm b/slsets.scm
index 92d7356..4b83cf4 100644
--- a/slsets.scm
+++ b/slsets.scm
@@ -78,12 +78,17 @@
 (define (slset-adjoin lst . els)
   (with-marked-list lst
                     (lambda (m)
-                      (let lp ((lst lst)
-                               (els els))
-                        (cond ((null? els) lst)
-                              ((marked? (car els) m) (lp lst (cdr els)))
-                              (else (mark! (car els) m)
-                                    (lp (cons (car els) lst) (cdr els))))))))
+                      (dynamic-wind
+                          void
+                          (lambda ()
+                            (let lp ((lst lst)
+                                     (els els))
+                              (cond ((null? els) lst)
+                                    ((marked? (car els) m) (lp lst (cdr els)))
+                                    (else (mark! (car els) m)
+                                          (lp (cons (car els) lst) (cdr els))))))
+                          (lambda ()
+                            (unmark-list! els m))))))
 
 (define (slset-difference lst . lsts)
   (let lp ((lsts lsts)
diff --git a/tests/run.scm b/tests/run.scm
index 06f4f2c..e2bf76b 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,7 +1,26 @@
 ;; (load "../slsets.scm")
-(import slsets test)
+(import slsets test (chicken plist))
+
+(define all-symbols '(a b c d e i o u x y z))
+(define all-plist-entries (apply append (map symbol-plist all-symbols)))
+
+(define (filter pred lst)
+  (let lp ((lst lst)
+           (res '()))
+    (cond ((null? lst) (reverse res))
+          ((not (pred (car lst))) (lp (cdr lst) res))
+          (else (lp (cdr lst) (cons (car lst) res))))))
+
+(define (clean? lst)
+  (if (null? lst)
+      #t
+      (and (null? (filter (lambda (x) (not (memq x all-plist-entries))) (symbol-plist (car lst))))
+           (clean? (cdr lst)))))
 
 (test-group "slsets"
+  (test-group "initially, all symbols used in any test are clean"
+    (test-assert (clean? all-symbols)))
+
   (test-group "slset<="
     (test-group "examples from srfi-1 document"
       (test-assert (slset<= '(a) '(a b a) '(a b c c)))
@@ -9,7 +28,9 @@
       (test-assert "trivial case one arg" (slset<= '(a))))
     (test-group "negatives"
       (test-assert (not (slset<= '(a b a) '(a b c c) '(a))))
-      (test-assert (not (slset<= '(a b) '(a c))))))
+      (test-assert (not (slset<= '(a b) '(a c)))))
+    (test-group "all symbols used here still clean"
+      (test-assert (clean? '(a b c)))))
 
   (test-group "slset="
     (test-group "examples from srfi-1 document"
@@ -19,7 +40,9 @@
     (test-group "negatives"
       (test-assert (not (slset= '(b e a) '(a e b x) '(e e b a))))
       (test-assert (not (slset= '(b e a x) '(a e b) '(e e b a))))
-      (test-assert (not (slset= '(b e a) '(a e b) '(e e b a x))))))
+      (test-assert (not (slset= '(b e a) '(a e b) '(e e b a x)))))
+    (test-group "all symbols used here still clean"
+      (test-assert (clean? '(a b e x)))))
 
   (test-group "slset-adjoin"
     (test-group "example from srfi-1 document"
@@ -29,7 +52,9 @@
     (test-group "result shares a common tail with the list argument"
       (let* ((lst '(a b c d c e))
              (result (slset-adjoin lst 'a 'x 'e 'b)))
-        (test-assert (eq? lst (cdr result))))))
+        (test-assert (eq? lst (cdr result)))))
+    (test-group "all symbols used here still clean"
+      (test-assert (clean? '(a b c d e i o u x)))))
 
   (test-group "slset-union"
     (test-group "examples from srfi-1 document"
@@ -42,7 +67,9 @@
             (slset-union))
       (test "trivial case one arg"
             '(a b c)
-            (slset-union '(a b c)))))
+            (slset-union '(a b c))))
+    (test-group "all symbols used here still clean"
+      (test-assert (clean? '(a b c d e i o u x)))))
 
   (test-group "slset-xor"
     (test-group "examples from srfi-1 document"
@@ -58,7 +85,9 @@
       (test "for multiple lists, returns elements that appear in an odd number of lists"
             '(c d i u e x) (slset-xor '(a b c d e) '(a e i o u) '(b o e) '(x)))
       (test "duplicates in lists are preserved"
-            '(b b c d d i o u o) (slset-xor '(a b b c d e d) '(a e i o u o)))))
+            '(b b c d d i o u o) (slset-xor '(a b b c d e d) '(a e i o u o))))
+    (test-group "all symbols used here still clean"
+      (test-assert (clean? '(a b c d e i o u x)))))
 
   (test-group "slset-difference"
     (test-group "examples from srfi-1 document"
@@ -77,7 +106,9 @@
             (slset-difference '() '(a b b c d e)))
       (test "empty list is still empty after other args"
             '()
-            (slset-difference '() '(a b) '(c d e) '()))))
+            (slset-difference '() '(a b) '(c d e) '())))
+    (test-group "all symbols used here still clean"
+      (test-assert (clean? '(a b c d e i o u x y z)))))
 
   (test-group "slset-intersection"
     (test-group "examples from srfi-1 document"
@@ -88,13 +119,20 @@
             '(a b c) (slset-intersection '(a b c))))
     (test-group "more examples"
       (test "multiple lists"
-            '(a a) (slset-intersection '(a x b y b a) '(x a x z) '(a b)))))
+            '(a a) (slset-intersection '(a x b y b a) '(x a x z) '(a b))))
+    (test-group "all symbols used here still clean"
+      (test-assert (clean? '(a b c d e i o u x y z)))))
 
   (test-group "slset-deduplicate (as per srfi-1's delete-duplicates)"
     (test-group "example from srfi-1 document"
       (test '(a b c z)
             (slset-deduplicate '(a b a c a b c z))))
     (test-group "more examples"
-      (test '() (slset-deduplicate '())))))
+      (test '() (slset-deduplicate '())))
+    (test-group "all symbols used here still clean"
+      (test-assert (clean? '(a b c z)))))
+
+  (test-group "finally, all symbols used in any test are still clean"
+    (test-assert (clean? all-symbols))))
 
 (test-exit)