[armedbear-cvs] r13931 - trunk/abcl/src/org/armedbear/lisp

[mevenson at common-lisp.net]

Author: mevenson
Date: Sun May  6 06:37:33 2012
New Revision: 13931

Log:
Fixes #196: STABLE-SORT is only stable for lists.

Somewhat kludgily fix the macrology submitted by Jorge Tavares to pass
all the newly failing ANSI tests introduced.  The macrology of
MERGE-VECTORS-BODY and MERGE-SORT-BODY required that the sequences
were of type SIMPLE-VECTOR.  But somehow, MERGE-SORT-BODY was not
working when asked to stable sort sequences of type BIT-VECTOR or
STRING, both of which are subtypes of VECTOR but not SIMPLE-VECTOR.

Modified:
   trunk/abcl/src/org/armedbear/lisp/sort.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/sort.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/sort.lisp	Sat May  5 12:48:16 2012	(r13930)
+++ trunk/abcl/src/org/armedbear/lisp/sort.lisp	Sun May  6 06:37:33 2012	(r13931)
@@ -52,6 +52,10 @@
 ;;; - the merge-vectors algorithm is inspired from the CCL base code 
 ;;;
 
+;;; http://trac.common-lisp.net/armedbear/ticket/196
+;;; TODO Restore the optimization for SIMPLE-VECTOR types by
+;;; conditionally using aref/svref instead of always using AREF
+
 (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))
@@ -95,7 +99,8 @@
 		   (loop 
 		     (if (funcall ,predicate ,k-b ,k-a)
 			 (progn 
-			   (setf (svref ,aux ,i-aux) ,v-b
+;;			   (setf (svref ,aux ,i-aux) ,v-b ;; FIXME Ticket #196
+			   (setf (aref ,aux ,i-aux) ,v-b
 				 ,i-aux (+ ,i-aux 1)
 				 ,i-b (+ ,i-b 1))
 			   (when (= ,i-b ,end-b) (return))
@@ -104,7 +109,8 @@
 				       `(,k-b (funcall ,key ,v-b))
 				       `(,k-b ,v-b))))
 			 (progn 
-			   (setf (svref ,aux ,i-aux) ,v-a
+;;			   (setf (svref ,aux ,i-aux) ,v-a ;; FIXME Ticket #196
+			   (setf (aref ,aux ,i-aux) ,v-a
 				 ,i-aux (+ ,i-aux 1)
 				 ,i-a (+ ,i-a 1))
 			   (when (= ,i-a ,end-a)
@@ -118,7 +124,8 @@
 				       `(,k-a (funcall ,key ,v-a))
 				       `(,k-a ,v-a))))))))
 	    (loop
-	      (setf (svref ,aux ,i-aux) ,v-a
+;;	      (setf (svref ,aux ,i-aux) ,v-a ;; FIXME Ticket #196
+	      (setf (aref ,aux ,i-aux) ,v-a
 		    ,i-a (+ ,i-a 1))
 	      (when (= ,i-a ,end-a) (return))
 	      (setf ,v-a (,ref ,a ,i-a)
@@ -156,7 +163,8 @@
 			 `(merge-vectors-body ,type ,ref ,sequence ,start ,mid ,sequence 
 					      ,mid ,end ,aux ,start ,predicate)))))
 	 (let ((,maux (make-array ,mend)))
-	   (declare (type simple-vector ,maux))
+;;	   (declare (type simple-vector ,maux))
+	   (declare (type vector ,maux))
 	   (,merge-sort-call ,msequence ,mstart ,mend ,mpredicate ,mkey ,maux nil))))))
 
 (defun merge-sort-vectors (sequence predicate key)