X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsort.lisp;h=78c291df62f671f82daf755624230f489d303ed6;hb=1d5e0a5293d69aa29c8c7b72cda555478622e913;hp=de92015c3540b245fe52e62f1e3b2114ff6b1857;hpb=8ac4c19014a23665e5842d0a989cb9d22d1592ed;p=sbcl.git

diff --git a/src/code/sort.lisp b/src/code/sort.lisp
index de92015..78c291d 100644
--- 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)))))