(in-package "SB!IMPL")
-;;; Like CMU CL, we use HEAPSORT. However, other than that, this code
-;;; isn't really related to the CMU CL code, since instead of trying
-;;; to generalize the CMU CL code to allow START and END values, this
-;;; code has been written from scratch following Chapter 7 of
-;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
-(defun sort-vector (vector start end predicate key)
- (sort-vector vector start end predicate key))
+(defun sort-vector (vector start end predicate-fun key-fun-or-nil)
+ (sort-vector vector start end predicate-fun key-fun-or-nil))
;;; This is MAYBE-INLINE because it's not too hard to have an
;;; application where sorting is a major bottleneck, and inlining it
#!+sb-doc
"Destructively sort SEQUENCE. PREDICATE should return non-NIL if
ARG1 is to precede ARG2."
- (let ((predicate-function (%coerce-callable-to-fun predicate))
- (key-function (and key (%coerce-callable-to-fun key))))
+ (let ((predicate-fun (%coerce-callable-to-fun predicate)))
(typecase sequence
- (list (stable-sort-list sequence predicate-function key-function))
+ (list
+ (stable-sort-list sequence
+ predicate-fun
+ (if key (%coerce-callable-to-fun key) #'identity)))
(vector
- (with-array-data ((vector (the vector sequence))
- (start 0)
- (end (length sequence)))
- (sort-vector vector start end predicate-function key-function))
+ (let ((key-fun-or-nil (and key (%coerce-callable-to-fun key))))
+ (with-array-data ((vector (the vector sequence))
+ (start 0)
+ (end (length sequence)))
+ (sort-vector vector start end predicate-fun key-fun-or-nil)))
sequence)
(t
(error 'simple-type-error
#!+sb-doc
"Destructively sort SEQUENCE. PREDICATE should return non-NIL if
ARG1 is to precede ARG2."
- (typecase sequence
- (simple-vector
- (stable-sort-simple-vector sequence predicate key))
- (list
- (stable-sort-list sequence predicate key))
- (vector
- (stable-sort-vector sequence predicate key))
- (t
- (error 'simple-type-error
- :datum sequence
- :expected-type 'sequence
- :format-control "~S is not a sequence."
- :format-arguments (list sequence)))))
-\f
+ (let ((predicate-fun (%coerce-callable-to-fun predicate)))
+ (typecase sequence
+ (simple-vector
+ (stable-sort-simple-vector sequence
+ predicate-fun
+ (and key (%coerce-callable-to-fun key))))
+ (list
+ (stable-sort-list sequence
+ predicate-fun
+ (if key (%coerce-callable-to-fun key) #'identity)))
+ (vector
+ (stable-sort-vector sequence
+ predicate-fun
+ (and key (%coerce-callable-to-fun key))))
+ (t
+ (error 'simple-type-error
+ :datum sequence
+ :expected-type 'sequence
+ :format-control "~S is not a sequence."
+ :format-arguments (list sequence))))))
+ \f
;;; APPLY-KEYED-PRED saves us a function call sometimes.
(eval-when (:compile-toplevel :execute)
(sb!xc:defmacro apply-keyed-pred (one two pred key)
;;; that is, there are only two runs that can be merged, the first run
;;; starting at the beginning of the list, and the second being the
;;; remaining elements.
-(defun stable-sort-list (list pred key)
+(defun stable-sort-list (list pred-fun key-fun)
(let ((head (cons :header list)) ; head holds on to everything
(n 1) ; bottom-up size of lists to be merged
unsorted ; unsorted is the remaining list to be
; broken into n size lists and merged
list-1 ; list-1 is one length n list to be merged
- last ; last points to the last visited cell
- (pred-fun (%coerce-callable-to-fun pred))
- (key-fun (if key
- (%coerce-callable-to-fun key)
- #'identity)))
- (declare (fixnum n))
+ last) ; last points to the last visited cell
+ (declare (type function pred-fun key-fun)
+ (type fixnum n))
(loop
;; Start collecting runs of N at the first element.
(setf unsorted (cdr head))
(declaim (simple-vector *merge-sort-temp-vector*))
(defun stable-sort-simple-vector (vector pred key)
- (declare (simple-vector vector))
+ (declare (type simple-vector vector)
+ (type function pred)
+ (type (or null function) key))
(vector-merge-sort vector pred key svref))
(defun stable-sort-vector (vector pred key)
+ (declare (type function pred)
+ (type (or null function) key))
(vector-merge-sort vector pred key aref))
\f
;;;; merging
(sequence-type-length-mismatch-error type
(+ (length s1)
(length s2)))))
- (if (csubtypep (specifier-type '(cons nil t)) type)
- (if (and (null s1) (null s2))
- (sequence-type-length-mismatch-error type 0)
- (values (merge-lists* s1 s2 pred-fun key-fun)))
+ (if (cons-type-p type)
+ (multiple-value-bind (min exactp)
+ (sb!kernel::cons-type-length-info type)
+ (let ((length (+ (length s1) (length s2))))
+ (if exactp
+ (unless (= length min)
+ (sequence-type-length-mismatch-error type length))
+ (unless (>= length min)
+ (sequence-type-length-mismatch-error type length)))
+ (values (merge-lists* s1 s2 pred-fun key-fun))))
(sequence-type-too-hairy result-type))))
((csubtypep type (specifier-type 'vector))
(let* ((vector-1 (coerce sequence1 'vector))
projects / sbcl.git / blobdiff