From 3c567e1c9acaa34cde1ca0df46f34895301b89d8 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Tue, 14 May 2013 21:44:38 +0200 Subject: [PATCH] Complete SUBST support with :test-not keyword parameter, error checking and tests --- src/list.lisp | 20 +++++++++++--------- tests/list.lisp | 18 ++++++++++++++++-- 2 files changed, 27 insertions(+), 11 deletions(-) diff --git a/src/list.lisp b/src/list.lisp index 9a445db..f7e15ec 100644 --- a/src/list.lisp +++ b/src/list.lisp @@ -113,6 +113,17 @@ (cons (s (car x)) (s (cdr x))))))) (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)))))))) + (s tree))) + (defun copy-list (x) (mapcar #'identity x)) @@ -135,15 +146,6 @@ (when (eql tail object) (return-from tailp t)))) -(defun subst (new old tree &key (key #'identity) (test #'eql)) - (cond - ((funcall test (funcall key tree) (funcall key old)) - new) - ((consp tree) - (cons (subst new old (car tree) :key key :test test) - (subst new old (cdr tree) :key key :test test))) - (t tree))) - (defmacro pop (place) (multiple-value-bind (dummies vals newval setter getter) (get-setf-expansion place) diff --git a/tests/list.lisp b/tests/list.lisp index f002e1e..77b93c6 100644 --- a/tests/list.lisp +++ b/tests/list.lisp @@ -93,6 +93,22 @@ (test (equal (sublis '(("two" . 2)) tree2 :test 'equal) '("one" ("one" 2) (("one" "Two" "three")))))) +;; SUBST +(let ((tree1 '(1 (1 2) (1 2 3) (1 2 3 4)))) + (test (equal (subst "two" 2 tree1) '(1 (1 "two") (1 "two" 3) (1 "two" 3 4)))) + (test (equal (subst "five" 5 tree1) '(1 (1 2) (1 2 3) (1 2 3 4)))) + (test (not (eq tree1 (subst "five" 5 tree1)))) ; Implementation dependent + (test (equal tree1 '(1 (1 2) (1 2 3) (1 2 3 4))))) +(test (equal (subst 'tempest 'hurricane + '(shakespeare wrote (the hurricane))) + '(SHAKESPEARE WROTE (THE TEMPEST)))) +(test (equal (subst 'foo 'nil '(shakespeare wrote (twelfth night))) + '(SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO))) +(test (equal (subst '(a . cons) '(old . pair) + '((old . spice) ((old . shoes) old . pair) (old . pair)) + :test #'equal) + '((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS)))) + ; COPY-TREE (test (let* ((foo (list '(1 2) '(3 4))) (bar (copy-tree foo))) @@ -169,8 +185,6 @@ (test (not (intersection '(1 2 3) '(4 5 6)))) (test (equal (intersection '((1) (2)) '((2) (3)) :test #'equal) '((2)))) -; SUBST - ; POP (test (let* ((foo '(1 2 3)) (bar (pop foo))) -- 1.7.10.4