From 8869320e6384306a93384cf93deb8e3a900ca49a Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Sun, 6 May 2012 14:27:25 +0900
Subject: [PATCH] fixing sorting with duplicates

---
 lib/srfi/95/qsort.c  | 26 ++++++++++++++++++++------
 tests/sort-tests.scm |  4 ++++
 2 files changed, 24 insertions(+), 6 deletions(-)

diff --git a/lib/srfi/95/qsort.c b/lib/srfi/95/qsort.c
index 6bafd978..acbc3e92 100644
--- a/lib/srfi/95/qsort.c
+++ b/lib/srfi/95/qsort.c
@@ -122,16 +122,24 @@ static sexp sexp_object_compare_op (sexp ctx, sexp self, sexp_sint_t n, sexp a,
 
 /* fast path when using general object-cmp comparator with no key */
 static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) {
-  sexp_sint_t mid, i, j;
+  sexp_sint_t mid, i, j, diff;
   sexp tmp, tmp2;
  loop:
   if (lo < hi) {
     mid = lo + (hi-lo)/2;
     swap(tmp, vec[mid], vec[hi]);
-    for (i=j=lo; i < hi; i++)
-      if (sexp_object_compare(ctx, vec[i], tmp) < 0)
-        swap(tmp2, vec[i], vec[j]), j++;
+    /* partition */
+    for (i=j=lo; i < hi; i++) {
+      diff = sexp_object_compare(ctx, vec[i], tmp);
+      if (diff < 0) {
+        swap(tmp2, vec[i], vec[j]);
+        j++;
+      } else if (diff == 0) {
+        j++;
+      }
+    }
     swap(tmp, vec[j], vec[hi]);
+    /* recurse */
     sexp_qsort(ctx, vec, lo, j-1);
     if (j < hi-1) {
       lo = j;
@@ -171,10 +179,16 @@ static sexp sexp_qsort_less (sexp ctx, sexp *vec,
       sexp_car(args2) = a;
       sexp_car(args1) = b;
       res = sexp_apply(ctx, less, args2);
-      if (sexp_exceptionp(res))
+      if (sexp_exceptionp(res)) {
         goto done;
-      else if (sexp_truep(res))
+      } else if (sexp_truep(res)) {
         swap(res, vec[i], vec[j]), j++;
+      } else {
+        sexp_car(args2) = b;
+        sexp_car(args1) = a;
+        res = sexp_apply(ctx, less, args2);
+        if (sexp_not(res)) j++;  /* equal */
+      }
     }
     swap(tmp, vec[j], vec[hi]);
     res = sexp_qsort_less(ctx, vec, lo, j-1, less, key);
diff --git a/tests/sort-tests.scm b/tests/sort-tests.scm
index e2798ab1..581096e9 100644
--- a/tests/sort-tests.scm
+++ b/tests/sort-tests.scm
@@ -8,11 +8,15 @@
 (test "sort null" '() (sort '()))
 (test "sort null <" '() (sort '() <))
 (test "sort null < car" '() (sort '() < car))
+(test "sort equal list" '(0 0 0 0 0 0 0 0 0) (sort '(0 0 0 0 0 0 0 0 0)))
+(test "sort equal list cmp" '(0 0 0 0 0 0 0 0 0)
+  (sort '(0 0 0 0 0 0 0 0 0) (lambda (a b) (< a b))))
 (test "sort ordered list" '(1 2 3 4 5 6 7 8 9) (sort '(1 2 3 4 5 6 7 8 9)))
 (test "sort reversed list" '(1 2 3 4 5 6 7 8 9) (sort '(9 8 7 6 5 4 3 2 1)))
 (test "sort random list 1" '(1 2 3 4 5 6 7 8 9) (sort '(7 5 2 8 1 6 4 9 3)))
 (test "sort random list 2" '(1 2 3 4 5 6 7 8) (sort '(5 3 4 1 7 6 8 2)))
 (test "sort random list 3" '(1 2 3 4 5 6 7 8 9) (sort '(5 3 4 1 7 9 6 8 2)))
+(test "sort short equal list" '(0 0 0) (sort '(0 0 0)))
 (test "sort short random list" '(1 2 3) (sort '(2 1 3)))
 (test "sort short random list cmp" '(1 2 3) (sort '(2 1 3) (lambda (a b) (< a b))))
 (test "sort numeric list <" '(1 2 3 4 5 6 7 8 9)