New function SB-IMPL:SCHWARTZIAN-STABLE-SORT-LIST

[sbcl.git] / src / code / early-extensions.lisp

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index dd7742e..b73ac29 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -1436,3 +1436,16 @@ to :INTERPRET, an interpreter will be used.")
                        (list (list :line lineno)
                              (list :column colno)
                              (list :file-position pos)))))))
+
+(declaim (inline schwartzian-stable-sort-list))
+(defun schwartzian-stable-sort-list (list comparator &key key)
+  (if (null key)
+      (stable-sort (copy-list list) comparator)
+      (let* ((key (if (functionp key)
+                      key
+                      (symbol-function key)))
+             (wrapped (mapcar (lambda (x)
+                                (cons x (funcall key x)))
+                              list))
+             (sorted (stable-sort wrapped comparator :key #'cdr)))
+        (map-into sorted #'car sorted))))