Skip to content
Snippets Groups Projects
Commit 1fecd525 authored by toy's avatar toy
Browse files

"Borrow" the fixed implementation of nset-exclusive-or from SBCL.

Alexey fixed in SBCL.
parent 38a9b365
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -827,52 +827,61 @@
;;; spliced out. When the end of list1 is reached, what is left of list2 is ;;; 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 ;;; tacked onto what is left of list1. The splicing operation ensures that
;;; the correct operation is performed depending on whether splice is at the ;;; the correct operation is performed depending on whether splice is at the
;;; top of the list or not ;;; top of the list or not.
#+nil (defun nset-exclusive-or (list1 list2
(defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp) &key key (test #'eql testp) (test-not #'eql notp))
key) "Destructively return a list with elements which appear but once in LIST1
"Destructively return a list with elements which appear but once in list1 and LIST2."
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) (do ((list1 list1)
(list2 list2) (list2 list2)
(x list1 (cdr x)) (x list1 (cdr x))
(splicex ())) (splicex ())
;; elements of LIST2, which are "equal" to some processed
;; earlier elements of LIST1
(deleted-y ()))
((endp x) ((endp x)
(if (null splicex) (if (null splicex)
(setq list1 list2) (setq list1 list2)
(rplacd splicex list2)) (rplacd splicex list2))
list1) list1)
(do ((y list2 (cdr y)) (let ((key-val-x (apply-key key (car x)))
(splicey ())) (found-duplicate nil))
((endp y) (setq splicex x))
(cond ((let ((key-val-x (apply-key key (car x))) ;; Move all elements from LIST2, which are "equal" to (CAR X),
(key-val-y (apply-key key (Car y)))) ;; to DELETED-Y.
(if notp (do* ((y list2 next-y)
(not (funcall test-not key-val-x key-val-y)) (next-y (cdr y) (cdr y))
(funcall test key-val-x key-val-y))) (splicey ()))
(if (null splicex) ((endp y))
(setq list1 (cdr x)) (cond ((let ((key-val-y (apply-key key (car y))))
(rplacd splicex (cdr x))) (if notp
(if (null splicey) (not (funcall test-not key-val-x key-val-y))
(setq list2 (cdr y)) (funcall test key-val-x key-val-y)))
(rplacd splicey (cdr y))) (if (null splicey)
(return ())) ; assume lists are really sets (setq list2 (cdr y))
(t (setq splicey y)))))) (rplacd splicey (cdr y)))
(setq deleted-y (rplacd y deleted-y))
;;; (setq found-duplicate t))
;;; The above #+nil'ed out version returns different results than (t (setq splicey y))))
;;; SET-EXCLUSIVE-OR, for instance, for (SET-EXCLUSIVE-OR '(1 1)
;;; '(1)). Let's use SET-EXCLUSIVE-OR, and wait for someone who cares (unless found-duplicate
;;; enough to fix the above algorithm. (setq found-duplicate (with-set-keys (member key-val-x deleted-y))))
;;;
(defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp) (if found-duplicate
key) (if (null splicex)
"Destructively return a list with elements which appear but once in list1 (setq list1 (cdr x))
and list2." (rplacd splicex (cdr x)))
(if notp (setq splicex x)))))
(set-exclusive-or list1 list2 :key key :test-not test-not)
(set-exclusive-or list1 list2 :key key :test test)))
(defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp)) (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp))
"Returns T if every element in list1 is also in list2." "Returns T if every element in list1 is also in list2."
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment