paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-08 04:48:07 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ added test for the sortbase unit

Browse Source 
git-svn-id: trunk@41195 -
This commit is contained in:
nickysn 2019-02-03 19:16:48 +00:00
parent d86da19570
commit 5c4af27a7a
4 changed files with 170 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -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

2
tests/Makefile
View File

@ -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

2
tests/Makefile.fpc
View File

@ -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

167
tests/test/units/sortbase/tsortbase.pp Normal file
View File

@ -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.