From 54f2996917c5e536930fd6111a6db3c04904f5e1 Mon Sep 17 00:00:00 2001 From: Owen Rodley Date: Sat, 4 May 2013 10:44:25 +1200 Subject: [PATCH] TREE-EQUAL --- src/list.lisp | 7 +++++++ src/toplevel.lisp | 2 +- tests/list.lisp | 6 ++++++ 3 files changed, 14 insertions(+), 1 deletion(-) diff --git a/src/list.lisp b/src/list.lisp index cb75bdc..fd9e0bd 100644 --- 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 --- 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 --- 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 -- 1.7.10.4