From 5c4af27a7ae30d89923b197105b9268913252951 Mon Sep 17 00:00:00 2001 From: nickysn Date: Sun, 3 Feb 2019 19:16:48 +0000 Subject: [PATCH] + added test for the sortbase unit git-svn-id: trunk@41195 - --- .gitattributes | 1 + tests/Makefile | 2 +- tests/Makefile.fpc | 2 +- tests/test/units/sortbase/tsortbase.pp | 167 +++++++++++++++++++++++++ 4 files changed, 170 insertions(+), 2 deletions(-) create mode 100644 tests/test/units/sortbase/tsortbase.pp diff --git a/.gitattributes b/.gitattributes index 782fc07bba..b6def01098 100644 --- a/.gitattributes +++ b/.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 diff --git a/tests/Makefile b/tests/Makefile index a4a7403cc1..72ed2bf07a 100644 --- a/tests/Makefile +++ b/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 diff --git a/tests/Makefile.fpc b/tests/Makefile.fpc index 3c5166ccfd..7e95ad7936 100644 --- a/tests/Makefile.fpc +++ b/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 diff --git a/tests/test/units/sortbase/tsortbase.pp b/tests/test/units/sortbase/tsortbase.pp new file mode 100644 index 0000000000..dd3900aa40 --- /dev/null +++ b/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.