0.7.9.4:

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

diff --git a/src/code/sort.lisp b/src/code/sort.lisp
index de92015..78c291d 100644 (file)
--- a/src/code/sort.lisp
+++ b/src/code/sort.lisp
@@ -235,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
-          (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))
@@ -422,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."
-  (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)))))