TREE-EQUAL

diff --git a/src/list.lisp b/src/list.lisp
index cb75bdc..fd9e0bd 100644 (file)
--- a/src/list.lisp
+++ b/src/list.lisp
@@ -103,6 +103,13 @@
           (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 subst (new old tree &key (key #'identity) (test #'eql))
   (cond 
     ((funcall test (funcall key tree) (funcall key old))

diff --git a/src/toplevel.lisp b/src/toplevel.lisp
index 1fb9d1b..bb91c9e 100644 (file)
--- a/src/toplevel.lisp
+++ b/src/toplevel.lisp
@@ -73,7 +73,7 @@
           return-from revappend reverse rplaca rplacd second set setf
           setq some string string-upcase string= stringp subseq subst
           symbol-function symbol-name symbol-package symbol-plist
-          symbol-value symbolp t tagbody third throw truncate unless
+          symbol-value symbolp t tagbody third throw tree-equal truncate unless
           unwind-protect values values-list variable warn when write-line
           write-string zerop))
 

diff --git a/tests/list.lisp b/tests/list.lisp
index 3ff5515..d422823 100644 (file)
--- a/tests/list.lisp
+++ b/tests/list.lisp
@@ -12,6 +12,12 @@
         (not (= (car (car foo))
                 (car (car bar))))))
 
+; TREE-EQUAL
+(test (tree-equal '(1 2 3) '(1 2 3)))
+(test (tree-equal '(1 (2 (3 4) 5) 6) '(1 (2 (3 4) 5) 6)))
+(test (tree-equal (cons 1 2) (cons 2 3)
+                  :test (lambda (a b) (not (= a b)))))
+
 ; SUBST
 ; Can't really test this until EQUAL works properly on lists