[Sbcl-commits] master: New function SB-IMPL:SCHWARTZIAN-STABLE-SORT-LIST

[Paul K. <pk...@us...>]

The branch "master" has been updated in SBCL:
       via  83ff95b8a70b1dc7cfffdf0a6bb7f4500ebe1ca1 (commit)
      from  34cd57c90426635eb8c7f63efd37e036c4b8d891 (commit)

- Log -----------------------------------------------------------------
commit 83ff95b8a70b1dc7cfffdf0a6bb7f4500ebe1ca1
Author: Paul Khuong <pv...@pv...>
Date:   Wed Nov 13 13:14:46 2013 -0500

    New function SB-IMPL:SCHWARTZIAN-STABLE-SORT-LIST
    
    Stable sort because we really ought to avoid normal sort if we want
    reproducible builds, and a Schwartzian transform because we sometimes
    sort with fairly computation-heavy sort keys.  Better have that to
    make it easy to DTRT.
---
 package-data-list.lisp-expr    |    1 +
 src/code/early-extensions.lisp |   13 +++++++++++++
 2 files changed, 14 insertions(+), 0 deletions(-)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index ca67d02..5730ea0 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1701,6 +1701,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "SCALE-DOUBLE-FLOAT"
                #!+long-float "SCALE-LONG-FLOAT"
                "SCALE-SINGLE-FLOAT"
+               "SCHWARTZIAN-STABLE-SORT-LIST"
                "SCRUB-POWER-CACHE"
                "SEQUENCEP" "SEQUENCE-COUNT" "SEQUENCE-END"
                "SEQUENCE-OF-CHECKED-LENGTH-GIVEN-TYPE"
diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index dd7742e..b73ac29 100644
--- 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))))

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


hooks/post-receive
-- 
SBCL