(declare (type index start end))
(declare (type function predicate))
(declare (type (or function null) key))
- (declare (optimize (speed 3) (safety 3) (debug 1) (space 1)))
+ ;; This used to be (OPTIMIZE (SPEED 3) (SAFETY 3)), but now
+ ;; (0.7.1.39) that (SAFETY 3) means "absolutely safe (including
+ ;; expensive things like %DETECT-STACK-EXHAUSTION)" we get closer
+ ;; to what we want by using (SPEED 2) (SAFETY 2): "pretty fast,
+ ;; pretty safe, and safety is no more important than speed".
+ (declare (optimize (speed 2) (safety 2) (debug 1) (space 1)))
(if (typep vector 'simple-vector)
;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
#!+sb-doc
"Destructively sort SEQUENCE. PREDICATE should return non-NIL if
ARG1 is to precede ARG2."
- (let ((predicate-function (%coerce-callable-to-function predicate))
- (key-function (and key (%coerce-callable-to-function key))))
+ (let ((predicate-function (%coerce-callable-to-fun predicate))
+ (key-function (and key (%coerce-callable-to-fun key))))
(typecase sequence
(list (sort-list sequence predicate-function key-function))
(vector
drag)))) ; and return pointer to last element.
(cond ((apply-pred (car list-2) (car list-1) pred key)
(rplacd p list-2) ; Append the lesser list to last cell of
- (setq p (cdr p)) ; result. Note: test must bo done for
+ (setq p (cdr p)) ; result. Note: test must be done for
(pop list-2)) ; LIST-2 < LIST-1 so merge will be
(T (rplacd p list-1) ; stable for LIST-1.
(setq p (cdr p))
#!+sb-doc
"Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
sequence of type RESULT-TYPE using PREDICATE to order the elements."
- (if (eq result-type 'list)
- (let ((result (merge-lists* (coerce sequence1 'list)
- (coerce sequence2 'list)
- predicate key)))
- result)
- (let* ((vector-1 (coerce sequence1 'vector))
- (vector-2 (coerce sequence2 'vector))
- (length-1 (length vector-1))
- (length-2 (length vector-2))
- (result (make-sequence-of-type result-type
- (+ length-1 length-2))))
- (declare (vector vector-1 vector-2)
- (fixnum length-1 length-2))
-
- #!+high-security (aver (typep result result-type))
- (if (and (simple-vector-p result)
- (simple-vector-p vector-1)
- (simple-vector-p vector-2))
- (merge-vectors vector-1 length-1 vector-2 length-2
- result predicate key svref)
- (merge-vectors vector-1 length-1 vector-2 length-2
- result predicate key aref)))))
+ (let ((type (specifier-type result-type)))
+ (cond
+ ((csubtypep type (specifier-type 'list))
+ ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
+ ;; benefits from the error checking there. Short of
+ ;; reimplementing everything, we can't do the same for the LIST
+ ;; case, so do relevant length checking here:
+ (let ((s1 (coerce sequence1 'list))
+ (s2 (coerce sequence2 'list)))
+ (when (type= type (specifier-type 'list))
+ (return-from merge (values (merge-lists* s1 s2 predicate key))))
+ (when (eq type *empty-type*)
+ (bad-sequence-type-error nil))
+ (when (type= type (specifier-type 'null))
+ (if (and (null s1) (null s2))
+ (return-from merge 'nil)
+ ;; FIXME: This will break on circular lists (as,
+ ;; indeed, will the whole MERGE function).
+ (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 predicate key)))
+ (sequence-type-too-hairy result-type))))
+ ((csubtypep type (specifier-type 'vector))
+ (let* ((vector-1 (coerce sequence1 'vector))
+ (vector-2 (coerce sequence2 'vector))
+ (length-1 (length vector-1))
+ (length-2 (length vector-2))
+ (result (make-sequence result-type
+ (+ length-1 length-2))))
+ (declare (vector vector-1 vector-2)
+ (fixnum length-1 length-2))
+ (if (and (simple-vector-p result)
+ (simple-vector-p vector-1)
+ (simple-vector-p vector-2))
+ (merge-vectors vector-1 length-1 vector-2 length-2
+ result predicate key svref)
+ (merge-vectors vector-1 length-1 vector-2 length-2
+ result predicate key aref))))
+ (t (bad-sequence-type-error result-type)))))