X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Flist.lisp;h=c0370b77f65ab65e47c6dbdcc974793ec851e8e0;hb=be500b83eef452b448bfb9225e12846908ac8fc9;hp=f7e15ec064b0db9a905431a0ab9e2acec99ad09b;hpb=3c567e1c9acaa34cde1ca0df46f34895301b89d8;p=jscl.git

diff --git a/src/list.lisp b/src/list.lisp
index f7e15ec..c0370b7 100644
--- a/src/list.lisp
+++ b/src/list.lisp
@@ -15,7 +15,7 @@
 
 ;;;; Various list functions
 
-(defun cons (x y ) (cons x y))
+(defun cons (x y) (cons x y))
 (defun consp (x) (consp x))
 
 (defun listp (x)
@@ -114,14 +114,17 @@
     (s tree)))
 
 (defun subst (new old tree &key key (test #'eql testp) (test-not #'eql test-not-p))
-  (when (and testp test-not-p)
-    (error "Both test and test-not are set"))
   (labels ((s (x)
-             (let ((key-val (if key (funcall key x) x)))
-               (cond
-                 ((funcall (if test-not-p test-not test) key-val old) new)
-                 ((atom x) x)
-                 (t (cons (s (car x)) (s (cdr x))))))))
+             (cond ((satisfies-test-p old x :key key :test test :testp testp
+                                      :test-not test-not :test-not-p test-not-p)
+                    new)
+                   ((atom x) x)
+                   (t (let ((a (s (car x)))
+                            (b (s (cdr x))))
+                        (if (and (eq a (car x))
+                                 (eq b (cdr x)))
+                            x
+                            (cons a b)))))))
     (s tree)))
 
 (defun copy-list (x)
@@ -133,12 +136,17 @@
           (copy-tree (cdr tree)))
     tree))
 
-(defun tree-equal (tree1 tree2 &key (test #'eql))
-  (if (atom tree1)
-    (and (atom tree2) (funcall test tree1 tree2))
-    (and (consp tree2)
-         (tree-equal (car tree1) (car tree2) :test test)
-         (tree-equal (cdr tree1) (cdr tree2) :test test))))
+(defun tree-equal (tree1 tree2 &key (test #'eql testp)
+                         (test-not #'eql test-not-p))
+  (when (and testp test-not-p) (error "Both test and test-not are set"))
+  (let ((func (if test-not-p (complement test-not) test)))
+    (labels ((%tree-equal (tree1 tree2)
+               (if (atom tree1)
+                 (and (atom tree2) (funcall func tree1 tree2))
+                 (and (consp tree2)
+                      (%tree-equal (car tree1) (car tree2))
+                      (%tree-equal (cdr tree1) (cdr tree2))))))
+      (%tree-equal tree1 tree2))))
 
 (defun tailp (object list)
   (do ((tail list (cdr tail)))
@@ -192,23 +200,27 @@
   (and (consp (cdr x))
        (cons (car x) (butlast (cdr x)))))
 
-(defun member (x list &key (key #'identity) (test #'eql))
+(defun member (x list &key key (test #'eql testp) (test-not #'eql test-not-p)) 
   (while list
-    (when (funcall test x (funcall key (car list)))
+    (when (satisfies-test-p x (car list) :key key :test test :testp testp
+                            :test-not test-not :test-not-p test-not-p)
       (return list))
     (setq list (cdr list))))
 
 
-(defun assoc (x alist &key (test #'eql))
+(defun assoc (x alist &key key (test #'eql testp) (test-not #'eql test-not-p))
   (while alist
-    (if (funcall test x (caar alist))
+    (if (satisfies-test-p x (caar alist) :key key :test test :testp testp
+                          :test-not test-not :test-not-p test-not-p)
       (return)
       (setq alist (cdr alist))))
   (car alist))
 
-(defun rassoc (x alist &key (test #'eql))
+(defun rassoc (x alist &key key (test #'eql) (test #'eql testp)
+                 (test-not #'eql test-not-p))
   (while alist
-    (if (funcall test x (cdar alist))
+    (if (satisfies-test-p x (cdar alist) :key key :test test :testp testp
+                          :test-not test-not :test-not-p test-not-p)
       (return)
       (setq alist (cdr alist))))
   (car alist))