Index: src/org/armedbear/lisp/sort.lisp
===================================================================
--- src/org/armedbear/lisp/sort.lisp	(revision 13869)
+++ src/org/armedbear/lisp/sort.lisp	(working copy)
@@ -33,27 +33,150 @@
 
 (require "EXTENSIBLE-SEQUENCES-BASE")
 
-(defun sort (sequence predicate &rest args &key key)
-  (sequence::seq-dispatch sequence
-    (sort-list sequence predicate key)
-    (quicksort sequence 0 (1- (length sequence)) predicate (or key #'identity))
-    (apply #'sequence:sort sequence predicate args)))
+;;;
+;;; STABLE SORT
+;;;
 
-(defun stable-sort (sequence predicate &rest args &key key)
-  (sequence::seq-dispatch sequence
-    (sort-list sequence predicate key)
-;;; Jorge Tavares: 
-;;; As a quick fix, I send in attach a patch that uses in stable-sort merge
-;;; sort for all sequences. This is done by coercing the sequence to list,
-;;; calling merge sort and coercing it back to the original sequence type.
-;;; However, as a long term improvement, the best solution would be to
-;;; implement a merge sort for non-list sequences.
-    (coerce (sort-list (coerce sequence 'list) 
-		       predicate
-		       key)
-	    (type-of sequence))
-    (apply #'sequence:stable-sort sequence predicate args)))
+;;;
+;;; MERGE SORT for vectors (and sequences in general)
+;;;
+;;; - top-down stable merge sort
+;;; - it is defined with 2 macros to allow a single algorithm 
+;;;   and multiple sequence types: merge-vectors-body and merge-sort-body
+;;; - merge-vectors-body merges two given sequences
+;;; - merge-sort-body contains the top-down algorithm
+;;; - the body macro is called by the merge-sort-vectors functions, 
+;;;   which typecases the type of sequence and expands the apropriate body
+;;; - more types of sequences/vectors can be added
+;;; - the macros generate the merge sort body with or without funcall to key
+;;; - the merge-vectors algorithm is inspired from the CCL base code 
+;;;
 
+(defmacro merge-vectors-body (type ref a start-a end-a b start-b end-b aux start-aux predicate &optional key)
+  (let ((i-a (gensym)) 
+	(i-b (gensym))
+	(i-aux (gensym))
+	(v-a (gensym))
+	(v-b (gensym))
+	(k-a (gensym))
+	(k-b (gensym))
+	(merge-block (gensym))) 
+    `(locally
+	 (declare (type fixnum ,start-a ,end-a ,start-b ,end-b ,start-aux)
+		  (type ,type ,a ,b)
+		  (type simple-vector ,aux)
+		  (type function ,predicate ,@(if key `(,key)))
+		  (optimize (speed 3) (safety 0)))
+       (block ,merge-block
+	  (let ((,i-a ,start-a)
+		(,i-b ,start-b)
+		(,i-aux ,start-aux)
+		,v-a ,v-b ,k-a ,k-b)
+	    (declare (type fixnum ,i-a ,i-b ,i-aux))
+	    (cond ((= ,start-a ,end-a)
+		   (when (= ,start-b ,end-b)
+		     (return-from ,merge-block))
+		   (setf ,i-a ,start-b
+			 ,end-a ,end-b
+			 ,a ,b
+			 ,v-a (,ref ,a ,i-a)))
+		  ((= ,start-b ,end-b)
+		   (setf ,i-a ,start-a
+			 ,v-a (,ref ,a ,i-a)))
+		  (t
+		   (setf ,v-a (,ref ,a ,i-a)
+			 ,v-b (,ref ,b ,i-b)
+			 ,@(if key 
+			       `(,k-a (funcall ,key ,v-a))
+			       `(,k-a ,v-a))
+			 ,@(if key 
+			       `(,k-b (funcall ,key ,v-b))
+			       `(,k-b ,v-b)))
+		   (loop 
+		     (if (funcall ,predicate ,k-b ,k-a)
+			 (progn 
+			   (setf (svref ,aux ,i-aux) ,v-b
+				 ,i-aux (+ ,i-aux 1)
+				 ,i-b (+ ,i-b 1))
+			   (when (= ,i-b ,end-b) (return))
+			   (setf ,v-b (,ref ,b ,i-b)
+				 ,@(if key 
+				       `(,k-b (funcall ,key ,v-b))
+				       `(,k-b ,v-b))))
+			 (progn 
+			   (setf (svref ,aux ,i-aux) ,v-a
+				 ,i-aux (+ ,i-aux 1)
+				 ,i-a (+ ,i-a 1))
+			   (when (= ,i-a ,end-a)
+			     (setf ,a ,b 
+				   ,i-a ,i-b 
+				   ,end-a ,end-b 
+				   ,v-a ,v-b)
+			     (return))
+			   (setf ,v-a (,ref ,a ,i-a)
+				 ,@(if key 
+				       `(,k-a (funcall ,key ,v-a))
+				       `(,k-a ,v-a))))))))
+	    (loop
+	      (setf (svref ,aux ,i-aux) ,v-a
+		    ,i-a (+ ,i-a 1))
+	      (when (= ,i-a ,end-a) (return))
+	      (setf ,v-a (,ref ,a ,i-a)
+		    ,i-aux (+ ,i-aux 1))))))))
+
+(defmacro merge-sort-body (type ref mpredicate mkey msequence mstart mend)
+  (let ((merge-sort-call (gensym))
+	(maux (gensym))
+	(aux (gensym))
+	(sequence (gensym))
+	(start (gensym))
+	(end (gensym))
+	(predicate (gensym))
+	(key (gensym))
+	(mid (gensym))
+	(direction (gensym)))
+    `(locally
+	 (declare (optimize (speed 3) (safety 0)))
+       (labels ((,merge-sort-call (,sequence ,start ,end ,predicate ,key ,aux ,direction)
+		  (declare (type function ,predicate ,@(if mkey `(,key)))
+			   (type fixnum ,start ,end)
+			   (type ,type ,sequence))
+		  (let ((,mid (+ ,start (ash (- ,end ,start) -1))))
+		    (declare (type fixnum ,mid))
+		    (if (<= (- ,mid 1) ,start)
+			(unless ,direction (setf (,ref ,aux ,start) (,ref ,sequence ,start)))
+			(,merge-sort-call ,sequence ,start ,mid ,predicate ,key ,aux (not ,direction)))
+		    (if (>= (+ ,mid 1) ,end)
+			(unless ,direction (setf (,ref ,aux ,mid) (,ref ,sequence ,mid)))
+			(,merge-sort-call ,sequence ,mid ,end ,predicate ,key ,aux (not ,direction)))
+		    (unless ,direction (psetq ,sequence ,aux ,aux ,sequence))
+		    ,(if mkey
+			 `(merge-vectors-body ,type ,ref ,sequence ,start ,mid ,sequence 
+					      ,mid ,end ,aux ,start ,predicate ,key)
+			 `(merge-vectors-body ,type ,ref ,sequence ,start ,mid ,sequence 
+					      ,mid ,end ,aux ,start ,predicate)))))
+	 (let ((,maux (make-array ,mend)))
+	   (declare (type simple-vector ,maux))
+	   (,merge-sort-call ,msequence ,mstart ,mend ,mpredicate ,mkey ,maux nil))))))
+
+(defun merge-sort-vectors (sequence predicate key)
+  (let ((end (length sequence)))
+    (typecase sequence
+      (simple-vector 
+       (if key
+	   (merge-sort-body simple-vector svref predicate key sequence 0 end)
+	   (merge-sort-body simple-vector svref predicate nil sequence 0 end)))
+      (vector 
+       (if key
+	   (merge-sort-body vector aref predicate key sequence 0 end)
+	   (merge-sort-body vector aref predicate nil sequence 0 end))))
+    sequence))
+
+
+;;;
+;;;  MERGE SORT for lists
+;;;
+
 ;; Adapted from SBCL.
 (declaim (ftype (function (list) cons) last-cons-of))
 (defun last-cons-of (list)
@@ -182,107 +305,105 @@
         (if (eq list-1 (cdr head))
             (return list-1))))))
 
-#|
-<> dc:author "Jorge Tavares" ;
-    dc:description 
-""" 
-The quicksort function picks the pivot by selecting a midpoint and
-also sorts the smaller partition first. These are enough to avoid the
-stack overflow problem as reported. I've performed some tests and it
-looks it is correct 
-"""" .
-|#
+
 ;;;
+;;; SORT 
+;;;
+
+;;;
 ;;; QUICKSORT
-;;; - the pivot is a middle point
+;;;
+;;; - algorithm is in the quicksort-body macro, so that it allows
+;;;   the use of different types (e.g., simple-vector, vector)
+;;; - the pivot is picked by selecting middle point
 ;;; - sorts the smaller partition first
+;;; - the macro generates the quicksort body with or without funcall to key
 ;;;
-(defun quicksort (vector start end predicate key)
-  (declare (type fixnum start end)
-	   (type function predicate key))
-  (if (< start end)
-      (let* ((i start)
-	     (j (1+ end))
-	     (p (+ start (ash (- end start) -1)))
-	     (d (aref vector p))
-	     (kd (funcall key d)))
-	(rotatef (aref vector p) (aref vector start))
-	(block outer-loop
-	  (loop
-	    (loop 
-	      (unless (> (decf j) i) (return-from outer-loop))
-	      (when (funcall predicate 
-			     (funcall key (aref vector j)) kd)
-		(return)))
-	    (loop 
-	      (unless (< (incf i) j) (return-from outer-loop))
-	      (unless (funcall predicate
-			       (funcall key (aref vector i)) kd)
-		(return)))
-	    (rotatef (aref vector i) (aref vector j))))
-	(setf (aref vector start) (aref vector j)
-	      (aref vector j) d)
-	(if (< (- j start) (- end j))
-	    (progn
-	      (quicksort vector start (1- j) predicate key)
-	      (quicksort vector (1+ j) end predicate key))
-	    (progn
-	      (quicksort vector (1+ j) end predicate key)
-	      (quicksort vector start (1- j) predicate key))))
-      vector))
 
-;;; DEPRECATED -- to be removed in abcl-1.4
-;;; From ECL.
-(defun quick-sort (seq start end pred key)
-  (unless key (setq key #'identity))
-  (if (<= end (1+ start))
-      seq
-      (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d)))
-        (block outer-loop
-          (loop (loop (decf k)
-                  (unless (< j k) (return-from outer-loop))
-                  (when (funcall pred (funcall key (elt seq k)) kd)
-                    (return)))
-            (loop (incf j)
-              (unless (< j k) (return-from outer-loop))
-              (unless (funcall pred (funcall key (elt seq j)) kd)
-                (return)))
-            (let ((temp (elt seq j)))
-              (setf (elt seq j) (elt seq k)
-                    (elt seq k) temp))))
-        (setf (elt seq start) (elt seq j)
-              (elt seq j) d)
-        (quick-sort seq start j pred key)
-        (quick-sort seq (1+ j) end pred key))))
+(defmacro quicksort-body (type ref mpredicate mkey sequence mstart mend)
+  (let ((quicksort-call (gensym))
+	(predicate (gensym))
+	(key (gensym))
+	(vector (gensym))
+	(start (gensym))
+	(end (gensym))
+	(i (gensym))
+	(j (gensym))
+	(p (gensym))
+	(d (gensym))
+	(kd (gensym)))
+    `(locally 
+	 (declare (speed 3) (safety 0))
+       (labels ((,quicksort-call (,vector ,start ,end ,predicate ,key)
+		   (declare (type function ,predicate ,@(if mkey `(,key)))
+			    (type fixnum ,start ,end)
+			    (type ,type ,sequence))
+		   (if (< ,start ,end)
+		       (let* ((,i ,start)
+			      (,j (1+ ,end))
+			      (,p (the fixnum (+ ,start (ash (- ,end ,start) -1))))
+			      (,d (,ref ,vector ,p))
+			      ,@(if mkey
+				    `((,kd (funcall ,key ,d)))
+				    `((,kd ,d))))
+			 (rotatef (,ref ,vector ,p) (,ref ,vector ,start))
+			 (block outer-loop
+			   (loop
+			     (loop 
+			       (unless (> (decf ,j) ,i) (return-from outer-loop))
+			       (when (funcall ,predicate 
+					      ,@(if mkey 
+						    `((funcall ,key (,ref ,vector ,j)))
+						    `((,ref ,vector ,j)))
+					      ,kd) (return)))
+			     (loop 
+			       (unless (< (incf ,i) ,j) (return-from outer-loop))
+			       (unless (funcall ,predicate
+						,@(if mkey 
+						    `((funcall ,key (,ref ,vector ,i)))
+						    `((,ref ,vector ,i)))
+						,kd) (return)))
+			     (rotatef (,ref ,vector ,i) (,ref ,vector ,j))))
+			 (setf (,ref ,vector ,start) (,ref ,vector ,j)
+			       (,ref ,vector ,j) ,d)
+			 (if (< (- ,j ,start) (- ,end ,j))
+			     (progn
+			       (,quicksort-call ,vector ,start (1- ,j) ,predicate ,key)
+			       (,quicksort-call ,vector (1+ ,j) ,end ,predicate ,key))
+			     (progn
+			       (,quicksort-call ,vector (1+ ,j) ,end ,predicate ,key)
+			       (,quicksort-call ,vector ,start (1- ,j) ,predicate ,key)))))))
+	 (,quicksort-call ,sequence ,mstart ,mend ,mpredicate ,mkey)))))
 
-;;; From ECL. Should already be user-extensible as it does no type dispatch
-;;; and uses only user-extensible functions.
-(defun merge (result-type sequence1 sequence2 predicate
-                          &key key
-                          &aux (l1 (length sequence1)) (l2 (length sequence2)))
-  (unless key (setq key #'identity))
-  (do ((newseq (make-sequence result-type (+ l1 l2)))
-       (j 0 (1+ j))
-       (i1 0)
-       (i2 0))
-    ((and (= i1 l1) (= i2 l2)) newseq)
-    (cond ((and (< i1 l1) (< i2 l2))
-           (cond ((funcall predicate
-                           (funcall key (elt sequence1 i1))
-                           (funcall key (elt sequence2 i2)))
-                  (setf (elt newseq j) (elt sequence1 i1))
-                  (incf i1))
-                 ((funcall predicate
-                           (funcall key (elt sequence2 i2))
-                           (funcall key (elt sequence1 i1)))
-                  (setf (elt newseq j) (elt sequence2 i2))
-                  (incf i2))
-                 (t
-                  (setf (elt newseq j) (elt sequence1 i1))
-                  (incf i1))))
-          ((< i1 l1)
-           (setf (elt newseq j) (elt sequence1 i1))
-           (incf i1))
-          (t
-           (setf (elt newseq j) (elt sequence2 i2))
-           (incf i2)))))
+(defun quicksort (sequence predicate key)
+  (let ((end (1- (length sequence))))
+    (typecase sequence
+      (simple-vector 
+       (if key
+	   (quicksort-body simple-vector svref predicate key sequence 0 end)
+	   (quicksort-body simple-vector svref predicate nil sequence 0 end)))
+      (vector 
+       (if key
+	   (quicksort-body vector aref predicate key sequence 0 end)
+	   (quicksort-body vector aref predicate nil sequence 0 end))))
+    sequence))
+
+
+;;;
+;;; main SORT and STABLE-SORT function calls
+;;;
+;;; - sort: quicksort and merge sort (only for lists)
+;;; - stable-sort: merge sort (all types)
+;;;
+
+(defun sort (sequence predicate &rest args &key key)
+  (sequence::seq-dispatch sequence
+    (sort-list sequence predicate key)
+    (quicksort sequence predicate key)
+    (apply #'sequence:sort sequence predicate args)))
+
+(defun stable-sort (sequence predicate &rest args &key key)
+  (sequence::seq-dispatch sequence
+    (sort-list sequence predicate key)
+    (merge-sort-vectors sequence predicate key)
+    (apply #'sequence:stable-sort sequence predicate args)))
