master: union: preserve the argument order passed to :test

The branch "master" has been updated in SBCL:
       via  c7b985482ab1db2efa403a846073b3759dd61adb (commit)
      from  374a5fe50e4905fd86b73b1fe874fce51567dfb8 (commit)

- Log -----------------------------------------------------------------
commit c7b985482ab1db2efa403a846073b3759dd61adb
Author: Stas Boukarev <[email protected]>
Date:   Tue May 5 07:33:09 2026 +0300

    union: preserve the argument order passed to :test
    
    Independent of the lengths of the input lists.
---
 src/code/list.lisp        | 41 ++++++++++++++++++++++++++++-------------
 src/compiler/ir1util.lisp | 11 +++++++----
 tests/list.pure.lisp      | 16 ++++++++++++++++
 3 files changed, 51 insertions(+), 17 deletions(-)

diff --git a/src/code/list.lisp b/src/code/list.lisp
index 02e46d138..5d4fb85e9 100644
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -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))
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index d8faabc22..0c43c2c9c 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -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.
diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp
index d30d37bb2..05727fcd2 100644
--- a/tests/list.pure.lisp
+++ b/tests/list.pure.lisp
@@ -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))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL