0.7.9.35:

[sbcl.git] / src / code / sort.lisp

diff --git a/src/code/sort.lisp b/src/code/sort.lisp
index 372f2c5..78c291d 100644 (file)
--- a/src/code/sort.lisp
+++ b/src/code/sort.lisp
@@ -79,7 +79,12 @@
     (declare (type index start end))
     (declare (type function predicate))
     (declare (type (or function null) key))
     (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.
     (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.

@@ -104,8 +109,8 @@
   #!+sb-doc
   "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
    ARG1 is to precede ARG2."
   #!+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
     (typecase sequence
       (list (sort-list sequence predicate-function key-function))
       (vector

@@ -230,7 +235,7 @@
                     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
                     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))
           (pop list-2))               ;   LIST-2 < LIST-1 so merge will be
          (T (rplacd p list-1)   ;   stable for LIST-1.
             (setq p (cdr p))

@@ -417,25 +422,46 @@
   #!+sb-doc
   "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
    sequence of type RESULT-TYPE using PREDICATE to order the elements."
   #!+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)))))