diff --git a/code/list.lisp b/code/list.lisp index e1b44915ec93c71a90192a76c42db031a081e60e..3b4fcb1783e2971e95bae99e783970ffcbdaf886 100644 --- a/code/list.lisp +++ b/code/list.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/list.lisp,v 1.29 2003/04/19 15:24:02 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/list.lisp,v 1.30 2003/04/22 16:49:27 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -827,52 +827,61 @@ ;;; spliced out. When the end of list1 is reached, what is left of list2 is ;;; tacked onto what is left of list1. The splicing operation ensures that ;;; the correct operation is performed depending on whether splice is at the -;;; top of the list or not - -#+nil -(defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp) - key) - "Destructively return a list with elements which appear but once in list1 - and list2." +;;; top of the list or not. + +(defun nset-exclusive-or (list1 list2 + &key key (test #'eql testp) (test-not #'eql notp)) + "Destructively return a list with elements which appear but once in LIST1 + and LIST2." + (when (and testp notp) + (error ":TEST and :TEST-NOT were both supplied.")) + ;; The outer loop examines LIST1 while the inner loop examines + ;; LIST2. If an element is found in LIST2 "equal" to the element + ;; in LIST1, both are spliced out. When the end of LIST1 is + ;; reached, what is left of LIST2 is tacked onto what is left of + ;; LIST1. The splicing operation ensures that the correct + ;; operation is performed depending on whether splice is at the + ;; top of the list or not. (do ((list1 list1) (list2 list2) (x list1 (cdr x)) - (splicex ())) + (splicex ()) + ;; elements of LIST2, which are "equal" to some processed + ;; earlier elements of LIST1 + (deleted-y ())) ((endp x) (if (null splicex) (setq list1 list2) (rplacd splicex list2)) list1) - (do ((y list2 (cdr y)) - (splicey ())) - ((endp y) (setq splicex x)) - (cond ((let ((key-val-x (apply-key key (car x))) - (key-val-y (apply-key key (Car y)))) - (if notp - (not (funcall test-not key-val-x key-val-y)) - (funcall test key-val-x key-val-y))) - (if (null splicex) - (setq list1 (cdr x)) - (rplacd splicex (cdr x))) - (if (null splicey) - (setq list2 (cdr y)) - (rplacd splicey (cdr y))) - (return ())) ; assume lists are really sets - (t (setq splicey y)))))) - -;;; -;;; The above #+nil'ed out version returns different results than -;;; SET-EXCLUSIVE-OR, for instance, for (SET-EXCLUSIVE-OR '(1 1) -;;; '(1)). Let's use SET-EXCLUSIVE-OR, and wait for someone who cares -;;; enough to fix the above algorithm. -;;; -(defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp) - key) - "Destructively return a list with elements which appear but once in list1 - and list2." - (if notp - (set-exclusive-or list1 list2 :key key :test-not test-not) - (set-exclusive-or list1 list2 :key key :test test))) + (let ((key-val-x (apply-key key (car x))) + (found-duplicate nil)) + + ;; Move all elements from LIST2, which are "equal" to (CAR X), + ;; to DELETED-Y. + (do* ((y list2 next-y) + (next-y (cdr y) (cdr y)) + (splicey ())) + ((endp y)) + (cond ((let ((key-val-y (apply-key key (car y)))) + (if notp + (not (funcall test-not key-val-x key-val-y)) + (funcall test key-val-x key-val-y))) + (if (null splicey) + (setq list2 (cdr y)) + (rplacd splicey (cdr y))) + (setq deleted-y (rplacd y deleted-y)) + (setq found-duplicate t)) + (t (setq splicey y)))) + + (unless found-duplicate + (setq found-duplicate (with-set-keys (member key-val-x deleted-y)))) + + (if found-duplicate + (if (null splicex) + (setq list1 (cdr x)) + (rplacd splicex (cdr x))) + (setq splicex x))))) (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns T if every element in list1 is also in list2."