+ added test for the sortbase unit

git-svn-id: trunk@41195 -

.gitattributes

@@ -14247,6 +14247,7 @@ tests/test/units/objects/testobj2.pp svneol=native#text/plain
 tests/test/units/sharemem/libtest.pp svneol=native#text/plain
 tests/test/units/sharemem/test1.pp svneol=native#text/plain
 tests/test/units/softfpu/sfttst.pp svneol=native#text/plain
+tests/test/units/sortbase/tsortbase.pp svneol=native#text/plain
 tests/test/units/strings/tstrcopy.pp svneol=native#text/plain
 tests/test/units/strings/tstrings1.pp svneol=native#text/plain
 tests/test/units/strutils/taddchar.pp svneol=native#text/plain

tests/Makefile

@@ -2229,7 +2229,7 @@ export LOG:=$(TEST_OUTPUTDIR)/log
 endif
 LOGFILES=$(TEST_OUTPUTDIR)/log $(TEST_OUTPUTDIR)/longlog $(TEST_OUTPUTDIR)/faillist
 LOGEXT=.testlog .tbslog .tbflog .webtbslog .webtbflog
-TESTUNITDIRS=system dos crt objects strings sysutils math sharemem strutils matrix lineinfo ucomplex fpwidestring cpu fmtbcd windows classes character dateutil fpcunit softfpu variants
+TESTUNITDIRS=system dos crt objects strings sysutils math sharemem strutils matrix lineinfo ucomplex fpwidestring cpu fmtbcd windows classes character dateutil fpcunit softfpu variants sortbase
 TESTDIRECTDIRS=
 TESTSUBDIRS=cg cg/variants cg/cdecl cpu16 cpu16/i8086 library opt $(addprefix units/,$(TESTUNITDIRS))
 TESTPACKAGESDIRS=win-base webtbs hash fcl-registry fcl-process zlib fcl-db fcl-xml cocoaint bzip2

tests/Makefile.fpc

@@ -154,7 +154,7 @@ LOGFILES=$(TEST_OUTPUTDIR)/log $(TEST_OUTPUTDIR)/longlog $(TEST_OUTPUTDIR)/faill
 LOGEXT=.testlog .tbslog .tbflog .webtbslog .webtbflog
 
 # Subdirs available in the test subdir
-TESTUNITDIRS=system dos crt objects strings sysutils math sharemem strutils matrix lineinfo ucomplex fpwidestring cpu fmtbcd windows classes character dateutil fpcunit softfpu variants
+TESTUNITDIRS=system dos crt objects strings sysutils math sharemem strutils matrix lineinfo ucomplex fpwidestring cpu fmtbcd windows classes character dateutil fpcunit softfpu variants sortbase
 TESTDIRECTDIRS=
 TESTSUBDIRS=cg cg/variants cg/cdecl cpu16 cpu16/i8086 library opt $(addprefix units/,$(TESTUNITDIRS))
 TESTPACKAGESDIRS=win-base webtbs hash fcl-registry fcl-process zlib fcl-db fcl-xml cocoaint bzip2

tests/test/units/sortbase/tsortbase.pp

@@ -0,0 +1,167 @@
+program tsortbase;
+
+{$MODE objfpc}
+
+uses
+  sortbase;
+
+const
+  Max = 100;
+
+  RelTestMin = 1;
+  RelTestMax = 7;
+
+type
+  PElement = ^Integer;
+  TElement = Integer;
+  TArray = array [0..Max] of TElement;
+  TPtrArray = array [0..Max] of PElement;
+
+procedure Fail;
+begin
+  Writeln('Err!');
+  Halt(1);
+end;
+
+procedure CheckEqual(const Arr1, Arr2: TArray; N: Integer);
+var
+  I: Integer;
+begin
+  for I := 0 to N - 1 do
+    if Arr1[I] <> Arr2[I] then
+      Fail;
+end;
+
+procedure CheckPtrArrayDerefEqual(const PtrArr: TPtrArray; const Arr: TArray; N: Integer);
+var
+  I: Integer;
+begin
+  for I := 0 to N - 1 do
+    if PtrArr[I]^ <> Arr[I] then
+      Fail;
+end;
+
+procedure InitPtrArr(const Arr: TArray; var PtrArr: TPtrArray; N: Integer);
+var
+  I: Integer;
+begin
+  for I := 0 to N - 1 do
+    PtrArr[I] := @Arr[I];
+end;
+
+procedure Sort(var Arr: TArray; N: Integer);
+var
+  I, J: Integer;
+  tmp: TElement;
+begin
+  for J := 1 to N - 1 do
+  begin
+    I := J;
+    tmp := Arr[I];
+    while (I > 0) and (Arr[I - 1] > tmp) do
+    begin
+      Arr[I] := Arr[I - 1];
+      Dec(I);
+    end;
+    Arr[I] := tmp;
+  end;
+end;
+
+function ListSortComparer_NoContext(Item1, Item2: Pointer): Integer;
+begin
+  if PElement(Item1)^ > PElement(Item2)^ then
+    Result := 1
+  else if PElement(Item1)^ < PElement(Item2)^ then
+    Result := -1
+  else
+    Result := 0;
+end;
+
+function ListSortComparer_Context(Item1, Item2, Context: Pointer): Integer;
+begin
+  if PElement(Item1)^ > PElement(Item2)^ then
+    Result := 1
+  else if PElement(Item1)^ < PElement(Item2)^ then
+    Result := -1
+  else
+    Result := 0;
+end;
+
+procedure ListSortCustomItemExchanger_Context(Item1, Item2, Context: Pointer);
+var
+  tmp: TElement;
+begin
+  tmp := PElement(Item1)^;
+  PElement(Item1)^ := PElement(Item2)^;
+  PElement(Item2)^ := tmp;
+end;
+
+procedure TestSort(const OrigArr: TArray; N: Integer);
+var
+  Arr, SortArr: TArray;
+  PtrArr: TPtrArray;
+begin
+  SortArr := OrigArr;
+  Sort(SortArr, N);
+
+  Arr := OrigArr;
+  DefaultSortingAlgorithm^.ItemListSorter_ContextComparer(@Arr[0], N, SizeOf(TElement), @ListSortComparer_Context, nil);
+  CheckEqual(Arr, SortArr, N);
+
+  Arr := OrigArr;
+  DefaultSortingAlgorithm^.ItemListSorter_CustomItemExchanger_ContextComparer(@Arr[0], N, SizeOf(TElement), @ListSortComparer_Context, @ListSortCustomItemExchanger_Context, nil);
+  CheckEqual(Arr, SortArr, N);
+
+  Arr := OrigArr;
+  InitPtrArr(Arr, PtrArr, N);
+  DefaultSortingAlgorithm^.PtrListSorter_ContextComparer(@PtrArr, N, @ListSortComparer_Context, nil);
+  CheckEqual(Arr, OrigArr, N);
+  CheckPtrArrayDerefEqual(PtrArr, SortArr, N);
+
+  Arr := OrigArr;
+  InitPtrArr(Arr, PtrArr, N);
+  DefaultSortingAlgorithm^.PtrListSorter_NoContextComparer(@PtrArr, N, @ListSortComparer_NoContext);
+  CheckEqual(Arr, OrigArr, N);
+  CheckPtrArrayDerefEqual(PtrArr, SortArr, N);
+end;
+
+{ brute force tests the sorting algorithms by generating all variations with
+  repetition of N elements chosen from the numbers [0..N-1]. This grows
+  extremely fast (O(N**N)), so should be used for small values of N only. }
+procedure TestAllVariations(N: Integer);
+var
+  Arr: TArray;
+  SortArr: TArray;
+
+  procedure Gen(P: Integer);
+  var
+    I: Integer;
+  begin
+    if P = N then
+    begin
+      TestSort(Arr, N);
+      exit;
+    end;
+    for I := 0 to N - 1 do
+    begin
+      Arr[P] := I;
+      Gen(P + 1);
+    end;
+  end;
+
+begin
+  Gen(0);
+end;
+
+procedure TestAllVariations;
+var
+  I: Integer;
+begin
+  for I := RelTestMin to RelTestMax do
+    TestAllVariations(I);
+end;
+
+begin
+  TestAllVariations;
+  Writeln('Ok!');
+end.