X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsort.lisp;h=78c291df62f671f82daf755624230f489d303ed6;hb=26148f0c8d7d35e1c5e1d363ade79552cbeb0386;hp=372f2c51c03b5a71dd8b8927d418514d91216fff;hpb=0dea4acb4216f9ee1182a6dc49483ec8d42babc5;p=sbcl.git

diff --git a/src/code/sort.lisp b/src/code/sort.lisp
index 372f2c5..78c291d 100644
--- 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 (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.
@@ -104,8 +109,8 @@
   #!+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
@@ -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
-	   (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))
@@ -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."
-  (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)))))