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 028707c..b73ac29 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -30,18 +30,23 @@
 (def!type hash ()
   `(integer 0 ,max-hash))
 
-;;; a type used for indexing into arrays, and for related quantities
-;;; like lengths of lists
+;;; a type used for indexing into sequences, and for related
+;;; quantities like lengths of lists and other sequences.
 ;;;
-;;; It's intentionally limited to one less than the
-;;; ARRAY-DIMENSION-LIMIT for efficiency reasons, because in SBCL
-;;; ARRAY-DIMENSION-LIMIT is MOST-POSITIVE-FIXNUM, and staying below
-;;; that lets the system know it can increment a value of this type
-;;; without having to worry about using a bignum to represent the
-;;; result.
+;;; A more correct value for the exclusive upper bound for indexing
+;;; would be (1- ARRAY-DIMENSION-LIMIT) since ARRAY-DIMENSION-LIMIT is
+;;; the exclusive maximum *size* of one array dimension (As specified
+;;; in CLHS entries for MAKE-ARRAY and "valid array dimensions"). The
+;;; current value is maintained to avoid breaking existing code that
+;;; also uses that type for upper bounds on indices (e.g. sequence
+;;; length).
 ;;;
-;;; (It should be safe to use ARRAY-DIMENSION-LIMIT as an exclusive
-;;; bound because ANSI specifies it as an exclusive bound.)
+;;; In SBCL, ARRAY-DIMENSION-LIMIT is arranged to be a little smaller
+;;; than MOST-POSITIVE-FIXNUM, for implementation (see comment above
+;;; ARRAY-DIMENSION-LIMIT) and efficiency reasons: staying below
+;;; MOST-POSITIVE-FIXNUM lets the system know it can increment a value
+;;; of type INDEX without having to worry about using a bignum to
+;;; represent the result.
 (def!type index () `(integer 0 (,sb!xc:array-dimension-limit)))
 
 ;;; like INDEX, but only up to half the maximum. Used by hash-table
@@ -710,13 +715,13 @@
 ;;; our equality tests, because MEMBER and friends refer to EQLity.
 ;;; So:
 (defun equal-but-no-car-recursion (x y)
-  (cond
-    ((eql x y) t)
-    ((consp x)
-     (and (consp y)
-          (eql (car x) (car y))
-          (equal-but-no-car-recursion (cdr x) (cdr y))))
-    (t nil)))
+  (do () (())
+    (cond ((eql x y) (return t))
+          ((and (consp x)
+                (consp y)
+                (eql (pop x) (pop y))))
+          (t
+           (return)))))
 \f
 ;;;; package idioms
 
@@ -1431,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))))