common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

union: preserve the argument order passed to :test

Browse source 
Independent of the lengths of the input lists.
This commit is contained in:
Stas Boukarev 2026-05-05 07:33:09 +03:00
parent 374a5fe50e
commit c7b985482a
3 changed files with 51 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

41
src/code/list.lisp
View file

@ -1042,12 +1042,18 @@
collect k)
;; Start with the initial result being the shorter of the inputs.
;; Search for each element of the longer in the shorter, adding the missing ones.
(multiple-value-bind (short long)
(if (< n1 n2) (values list1 list2) (values list2 list1))
(let ((result short))
(dolist (elt long result)
(unless (funcall member-test elt short key test)
(push elt result)))))))))
(flet ((swapped-test (x y)
(funcall test y x)))
(declare (dynamic-extent #'swapped-test))
(multiple-value-bind (short long test)
(if (< n1 n2)
(values list1 list2 (and test
#'swapped-test))
(values list2 list1 test))
(let ((result short))
(dolist (elt long result)
(unless (funcall member-test elt short key test)
(push elt result))))))))))
(defun nunion (list1 list2 &key key (test nil testp) (test-not nil notp))
"Destructively return the union of LIST1 and LIST2."
@ -1060,7 +1066,10 @@
((null list2) (return-from nunion list1)))
(binding* ((n1 (length list1))
(n2 (length list2))
((short long) (if (< n1 n2) (values list1 list2) (values list2 list1)))
((short long swap)
(if (< n1 n2)
(values list1 list2 t)
(values list2 list1 nil)))
(hash-table (hashing-p notp testp test n1 n2)))
(if hash-table
(let ((table (unionize hash-table key short long))
@ -1074,12 +1083,18 @@
(push v union))) ; easier than re-using cons cells of SHORT
table)
union)
(do ((orig short)
(elt (car long) (car long)))
((endp long) short)
(if (funcall member-test elt orig key test)
(pop long)
(shiftf long (cdr long) short long))))))))
(flet ((swapped-test (x y)
(funcall (truly-the function test) y x)))
(declare (dynamic-extent #'swapped-test))
(let ((test (if swap
(and test #'swapped-test)
test)))
(do ((orig short)
(elt (car long) (car long)))
((endp long) short)
(if (funcall member-test elt orig key test)
(pop long)
(shiftf long (cdr long) short long))))))))))
(defun intersection (list1 list2
&key key (test nil testp) (test-not nil notp))

11
src/compiler/ir1util.lisp
View file

@ -1547,10 +1547,13 @@
(lvar-dest lvar))))
(when (and (combination-p combination)
(eq (combination-fun combination) lvar))
(loop for v in vars
for arg in (combination-args combination)
when (eq v var)
return arg))))))
(let ((args (combination-args combination)))
(when (functional-kind-eq fun external toplevel-xep)
(pop args)) ;; arg-count
(loop for v in vars
for arg in args
when (eq v var)
return arg)))))))
;;; Return the Top Level Form number of PATH, i.e. the ordinal number
;;; of its original source's top level form in its compilation unit.

16
tests/list.pure.lisp
View file

@ -466,3 +466,19 @@
(compile 'try-dx-acons)
(with-test (:name :compiled-acons)
(assert (try-dx-acons 1 2 3 '((1 . 2) . 3))))
(with-test (:name :sets-test-order)
(flet ((test-fun (a b)
(declare (integer a) (float b))
(= a b)))
(mapc (lambda (fun)
(funcall (opaque-identity fun)
(list 1 2 3) (list 1.0 2.0 3.0 4.0)
:test #'test-fun)
(funcall (opaque-identity fun)
(list 1 2 3 4) (list 1.0 2.0 3.0)
:test #'test-fun))
'(union nunion intersection nintersection
set-difference nset-difference
set-exclusive-or nset-exclusive-or
subsetp))))