Raymond Toy pushed to branch master at cmucl / cmucl
Commits:
-
db531fef
by Raymond Toy at 2023-08-30T17:59:50+00:00
-
766c6aa5
by Raymond Toy at 2023-08-30T18:00:08+00:00
3 changed files:
Changes:
| ... | ... | @@ -928,7 +928,7 @@ |
| 928 | 928 | |
| 929 | 929 | (defun set-exclusive-or (list1 list2 &key key
|
| 930 | 930 | (test #'eql testp) (test-not nil notp))
|
| 931 | - "Return new list of elements appearing exactly once in LIST1 and LIST2."
|
|
| 931 | + "Return new list of elements appearing exactly one of LIST1 and LIST2."
|
|
| 932 | 932 | (declare (inline member))
|
| 933 | 933 | (let ((result nil)
|
| 934 | 934 | (key (when key (coerce key 'function)))
|
| ... | ... | @@ -936,19 +936,38 @@ |
| 936 | 936 | (test-not (if test-not (coerce test-not 'function) #'eql)))
|
| 937 | 937 | (declare (type (or function null) key)
|
| 938 | 938 | (type function test test-not))
|
| 939 | - (dolist (elt list1)
|
|
| 940 | - (unless (with-set-keys (member (apply-key key elt) list2))
|
|
| 941 | - (setq result (cons elt result))))
|
|
| 942 | - (let ((test (if testp
|
|
| 943 | - (lambda (x y) (funcall test y x))
|
|
| 944 | - test))
|
|
| 945 | - (test-not (if notp
|
|
| 946 | - (lambda (x y) (funcall test-not y x))
|
|
| 947 | - test-not)))
|
|
| 948 | - (dolist (elt list2)
|
|
| 949 | - (unless (with-set-keys (member (apply-key key elt) list1))
|
|
| 950 | - (setq result (cons elt result)))))
|
|
| 951 | - result))
|
|
| 939 | + ;; Find the elements in list1 that do not appear in list2 and add
|
|
| 940 | + ;; them to the result.
|
|
| 941 | + (macrolet
|
|
| 942 | + ((compute-membership (item-list test-form)
|
|
| 943 | + `(dolist (elt ,item-list)
|
|
| 944 | + (unless ,test-form
|
|
| 945 | + (setq result (cons elt result))))))
|
|
| 946 | + (let ((hashtable (list-to-hashtable list2 key test test-not)))
|
|
| 947 | + (cond
|
|
| 948 | + (hashtable
|
|
| 949 | + (compute-membership list1
|
|
| 950 | + (nth-value 1 (gethash (apply-key key elt) hashtable))))
|
|
| 951 | + (t
|
|
| 952 | + (compute-membership list1
|
|
| 953 | + (with-set-keys (member (apply-key key elt) list2))))))
|
|
| 954 | + ;; Now find the elements in list2 that do not appear in list1 and
|
|
| 955 | + ;; them to the result.
|
|
| 956 | + (let ((hashtable (list-to-hashtable list1 key test test-not)))
|
|
| 957 | + (cond
|
|
| 958 | + (hashtable
|
|
| 959 | + (compute-membership list2
|
|
| 960 | + (nth-value 1 (gethash (apply-key key elt) hashtable))))
|
|
| 961 | + (t
|
|
| 962 | + (let ((test (if testp
|
|
| 963 | + (lambda (x y) (funcall test y x))
|
|
| 964 | + test))
|
|
| 965 | + (test-not (if notp
|
|
| 966 | + (lambda (x y) (funcall test-not y x))
|
|
| 967 | + test-not)))
|
|
| 968 | + (compute-membership list2
|
|
| 969 | + (with-set-keys (member (apply-key key elt) list1)))))))
|
|
| 970 | + result)))
|
|
| 952 | 971 | |
| 953 | 972 | |
| 954 | 973 | ;;; The outer loop examines list1 while the inner loop examines list2. If an
|
| ... | ... | @@ -3236,7 +3236,7 @@ msgid "Destructively returns the elements of list1 which are not in list2." |
| 3236 | 3236 | msgstr ""
|
| 3237 | 3237 | |
| 3238 | 3238 | #: src/code/list.lisp
|
| 3239 | -msgid "Return new list of elements appearing exactly once in LIST1 and LIST2."
|
|
| 3239 | +msgid "Return new list of elements appearing exactly one of LIST1 and LIST2."
|
|
| 3240 | 3240 | msgstr ""
|
| 3241 | 3241 | |
| 3242 | 3242 | #: src/code/list.lisp
|
| ... | ... | @@ -279,3 +279,26 @@ |
| 279 | 279 | '(3 4)
|
| 280 | 280 | :test 'eql
|
| 281 | 281 | :test-not 'equal)))
|
| 282 | + |
|
| 283 | +(define-test set-exclusive-or.1
|
|
| 284 | + (:tag :issues)
|
|
| 285 | + (flet
|
|
| 286 | + ((test (min-length)
|
|
| 287 | + ;; From CLHS
|
|
| 288 | + (let ((lisp::*min-list-length-for-hashtable* min-length))
|
|
| 289 | + (assert-equal '("b" "A" "b" "a")
|
|
| 290 | + (set-exclusive-or '(1 "a" "b")
|
|
| 291 | + '(1 "A" "b")))
|
|
| 292 | + (assert-equal '("A" "a")
|
|
| 293 | + (set-exclusive-or '(1 "a" "b")
|
|
| 294 | + '(1 "A" "b")
|
|
| 295 | + :test #'equal))
|
|
| 296 | + (assert-equal nil
|
|
| 297 | + (set-exclusive-or '(1 "a" "b")
|
|
| 298 | + '(1 "A" "b")
|
|
| 299 | + :test #'equalp)))))
|
|
| 300 | + ;; Test the list impl by making the min length large. Then test
|
|
| 301 | + ;; the hashtable impl with a very short min length
|
|
| 302 | + (test 100)
|
|
| 303 | + (test 2)))
|
|
| 304 | + |