mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-08 04:48:07 +02:00
* move utility code to a separate unit
git-svn-id: trunk@40692 -
This commit is contained in:
svenbarth
parent
3c9a5e5602
commit
bef1b84d63
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -7587,6 +7587,7 @@ packages/rtl-objpas/src/x86_64/invoke.inc svneol=native#text/plain
|
||||
packages/rtl-objpas/tests/testrunner.rtlobjpas.pp svneol=native#text/pascal
|
||||
packages/rtl-objpas/tests/tests.rtti.invoke.pas svneol=native#text/pascal
|
||||
packages/rtl-objpas/tests/tests.rtti.pas svneol=native#text/plain
|
||||
packages/rtl-objpas/tests/tests.rtti.util.pas svneol=native#text/pascal
|
||||
packages/rtl-unicode/Makefile svneol=native#text/plain
|
||||
packages/rtl-unicode/Makefile.fpc svneol=native#text/plain
|
||||
packages/rtl-unicode/fpmake.pp svneol=native#text/plain
|
||||
|
||||
@ -14,13 +14,10 @@ uses
|
||||
{$ELSE FPC}
|
||||
TestFramework,
|
||||
{$ENDIF FPC}
|
||||
sysutils, typinfo, Rtti;
|
||||
sysutils, typinfo, Rtti,
|
||||
Tests.Rtti.Util;
|
||||
|
||||
type
|
||||
{$ifndef fpc}
|
||||
CodePointer = Pointer;
|
||||
{$endif}
|
||||
|
||||
TTestInvoke = class(TTestCase)
|
||||
private type
|
||||
TInvokeFlag = (
|
||||
@ -29,8 +26,6 @@ type
|
||||
);
|
||||
TInvokeFlags = set of TInvokeFlag;
|
||||
private
|
||||
function EqualValues(aValue1, aValue2: TValue): Boolean;
|
||||
|
||||
function DoInvoke(aCodeAddress: CodePointer; aArgs: TValueArray; aCallConv: TCallConv; aResultType: PTypeInfo; aFlags: TInvokeFlags; out aValid: Boolean): TValue;
|
||||
procedure DoStaticInvokeTestOrdinalCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; aResult: Int64);
|
||||
procedure DoStaticInvokeTestAnsiStringCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: AnsiString);
|
||||
@ -72,132 +67,8 @@ type
|
||||
procedure TestProcRecs;
|
||||
end;
|
||||
|
||||
{$ifndef fpc}
|
||||
TValueHelper = record helper for TValue
|
||||
function AsUnicodeString: UnicodeString;
|
||||
function AsAnsiString: AnsiString;
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
implementation
|
||||
|
||||
{$ifndef fpc}
|
||||
function TValueHelper.AsUnicodeString: UnicodeString;
|
||||
begin
|
||||
Result := UnicodeString(AsString);
|
||||
end;
|
||||
|
||||
function TValueHelper.AsAnsiString: AnsiString;
|
||||
begin
|
||||
Result := AnsiString(AsString);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
function TTestInvoke.EqualValues(aValue1, aValue2: TValue): Boolean;
|
||||
var
|
||||
td1, td2: PTypeData;
|
||||
i: SizeInt;
|
||||
begin
|
||||
{$ifdef debug}
|
||||
Writeln('Empty: ', aValue1.IsEmpty, ' ', aValue2.IsEmpty);
|
||||
Writeln('Kind: ', aValue1.Kind, ' ', aValue2.Kind);
|
||||
Writeln('Array: ', aValue1.IsArray, ' ', aValue2.IsArray);
|
||||
{$endif}
|
||||
if aValue1.IsEmpty and aValue2.IsEmpty then
|
||||
Result := True
|
||||
else if aValue1.IsEmpty and not aValue2.IsEmpty then
|
||||
Result := False
|
||||
else if not aValue1.IsEmpty and aValue2.IsEmpty then
|
||||
Result := False
|
||||
else if aValue1.IsArray and aValue2.IsArray then begin
|
||||
if aValue1.GetArrayLength = aValue2.GetArrayLength then begin
|
||||
Result := True;
|
||||
for i := 0 to aValue1.GetArrayLength - 1 do
|
||||
if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin
|
||||
Writeln('Element ', i, ' differs: ', HexStr(aValue1.GetArrayElement(i).AsOrdinal, 4), ' ', HexStr(aValue2.GetArrayElement(i).AsOrdinal, 4));
|
||||
Result := False;
|
||||
Break;
|
||||
end;
|
||||
end else
|
||||
Result := False;
|
||||
end else if aValue1.Kind = aValue2.Kind then begin
|
||||
td1 := aValue1.TypeData;
|
||||
td2 := aValue2.TypeData;
|
||||
case aValue1.Kind of
|
||||
tkBool:
|
||||
Result := aValue1.AsBoolean xor not aValue2.AsBoolean;
|
||||
tkSet:
|
||||
if td1^.SetSize = td2^.SetSize then
|
||||
if td1^.SetSize < SizeOf(SizeInt) then
|
||||
Result := aValue1.AsOrdinal = aValue2.AsOrdinal
|
||||
else
|
||||
Result := CompareMem(aValue1.GetReferenceToRawData, aValue2.GetReferenceToRawData, td1^.SetSize)
|
||||
else
|
||||
Result := False;
|
||||
tkEnumeration,
|
||||
tkChar,
|
||||
tkWChar,
|
||||
tkUChar,
|
||||
tkInt64,
|
||||
tkInteger:
|
||||
Result := aValue1.AsOrdinal = aValue2.AsOrdinal;
|
||||
tkQWord:
|
||||
Result := aValue1.AsUInt64 = aValue2.AsUInt64;
|
||||
tkFloat:
|
||||
if td1^.FloatType <> td2^.FloatType then
|
||||
Result := False
|
||||
else begin
|
||||
case td1^.FloatType of
|
||||
ftSingle,
|
||||
ftDouble,
|
||||
ftExtended:
|
||||
Result := aValue1.AsExtended = aValue2.AsExtended;
|
||||
ftComp:
|
||||
Result := aValue1.AsInt64 = aValue2.AsInt64;
|
||||
ftCurr:
|
||||
Result := aValue1.AsCurrency = aValue2.AsCurrency;
|
||||
end;
|
||||
end;
|
||||
tkSString,
|
||||
tkUString,
|
||||
tkAString,
|
||||
tkWString:
|
||||
Result := aValue1.AsString = aValue2.AsString;
|
||||
tkDynArray,
|
||||
tkArray:
|
||||
if aValue1.GetArrayLength = aValue2.GetArrayLength then begin
|
||||
Result := True;
|
||||
for i := 0 to aValue1.GetArrayLength - 1 do
|
||||
if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin
|
||||
Result := False;
|
||||
Break;
|
||||
end;
|
||||
end else
|
||||
Result := False;
|
||||
tkClass,
|
||||
tkClassRef,
|
||||
tkInterface,
|
||||
tkInterfaceRaw,
|
||||
tkPointer:
|
||||
Result := PPointer(aValue1.GetReferenceToRawData)^ = PPointer(aValue2.GetReferenceToRawData)^;
|
||||
tkProcVar:
|
||||
Result := PCodePointer(aValue1.GetReferenceToRawData)^ = PCodePointer(aValue2.GetReferenceToRawData)^;
|
||||
tkRecord,
|
||||
tkObject,
|
||||
tkMethod,
|
||||
tkVariant: begin
|
||||
if aValue1.DataSize = aValue2.DataSize then
|
||||
Result := CompareMem(aValue1.GetReferenceToRawData, aValue2.GetReferenceToRawData, aValue1.DataSize)
|
||||
else
|
||||
Result := False;
|
||||
end
|
||||
else
|
||||
Result := False;
|
||||
end;
|
||||
end else
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
function TTestInvoke.DoInvoke(aCodeAddress: CodePointer; aArgs: TValueArray;
|
||||
aCallConv: TCallConv; aResultType: PTypeInfo; aFlags: TInvokeFlags; out aValid: Boolean): TValue;
|
||||
begin
|
||||
@ -1616,24 +1487,6 @@ begin
|
||||
Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize10(aArg1);
|
||||
end;
|
||||
|
||||
function CopyValue({$ifdef fpc}constref{$else}const [ref]{$endif} aValue: TValue): TValue;
|
||||
var
|
||||
arrptr: Pointer;
|
||||
len, i: SizeInt;
|
||||
begin
|
||||
if aValue.Kind = tkDynArray then begin
|
||||
{ we need to decouple the source reference, so we're going to be a bit
|
||||
cheeky here }
|
||||
len := aValue.GetArrayLength;
|
||||
arrptr := Nil;
|
||||
DynArraySetLength(arrptr, aValue.TypeInfo, 1, @len);
|
||||
TValue.Make(@arrptr, aValue.TypeInfo, Result);
|
||||
for i := 0 to len - 1 do
|
||||
Result.SetArrayElement(i, aValue.GetArrayElement(i));
|
||||
end else
|
||||
TValue.Make(aValue.GetReferenceToRawData, aValue.TypeInfo, Result);
|
||||
end;
|
||||
|
||||
procedure TTestInvoke.DoIntfInvoke(aIndex: SizeInt; aInputArgs,
|
||||
aOutputArgs: TValueArray; aResult: TValue);
|
||||
var
|
||||
@ -1899,54 +1752,6 @@ begin
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
function GetIntValue(aValue: SizeInt): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<SizeInt>(aValue);
|
||||
end;
|
||||
|
||||
function GetAnsiString(const aValue: AnsiString): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>(aValue);
|
||||
end;
|
||||
|
||||
function GetShortString(const aValue: ShortString): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<ShortString>(aValue);
|
||||
end;
|
||||
|
||||
function GetSingleValue(aValue: Single): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<Single>(aValue);
|
||||
end;
|
||||
|
||||
function GetDoubleValue(aValue: Double): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<Double>(aValue);
|
||||
end;
|
||||
|
||||
function GetExtendedValue(aValue: Extended): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<Extended>(aValue);
|
||||
end;
|
||||
|
||||
function GetCompValue(aValue: Comp): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<Comp>(aValue);
|
||||
end;
|
||||
|
||||
function GetCurrencyValue(aValue: Currency): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<Currency>(aValue);
|
||||
end;
|
||||
|
||||
|
||||
{$ifdef fpc}
|
||||
function GetArray(const aArg: array of SizeInt): TValue;
|
||||
begin
|
||||
Result := specialize OpenArrayToDynArrayValue<SizeInt>(aArg);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
procedure TTestInvoke.TestIntfMethods;
|
||||
begin
|
||||
DoIntfInvoke(1, [], [], TValue.Empty);
|
||||
|
||||
221
packages/rtl-objpas/tests/tests.rtti.util.pas
Normal file
221
packages/rtl-objpas/tests/tests.rtti.util.pas
Normal file
@ -0,0 +1,221 @@
|
||||
unit Tests.Rtti.Util;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Rtti;
|
||||
|
||||
{$ifndef fpc}
|
||||
type
|
||||
CodePointer = Pointer;
|
||||
|
||||
TValueHelper = record helper for TValue
|
||||
function AsUnicodeString: UnicodeString;
|
||||
function AsAnsiString: AnsiString;
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
function CopyValue({$ifdef fpc}constref{$else}const [ref]{$endif} aValue: TValue): TValue;
|
||||
function EqualValues({$ifdef fpc}constref{$else}const [ref]{$endif} aValue1, aValue2: TValue): Boolean;
|
||||
|
||||
function GetIntValue(aValue: SizeInt): TValue;
|
||||
function GetAnsiString(const aValue: AnsiString): TValue;
|
||||
function GetShortString(const aValue: ShortString): TValue;
|
||||
function GetSingleValue(aValue: Single): TValue;
|
||||
function GetDoubleValue(aValue: Double): TValue;
|
||||
function GetExtendedValue(aValue: Extended): TValue;
|
||||
function GetCompValue(aValue: Comp): TValue;
|
||||
function GetCurrencyValue(aValue: Currency): TValue;
|
||||
function GetArray(const aArg: array of SizeInt): TValue;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
TypInfo, SysUtils;
|
||||
|
||||
{$ifndef fpc}
|
||||
function TValueHelper.AsUnicodeString: UnicodeString;
|
||||
begin
|
||||
Result := UnicodeString(AsString);
|
||||
end;
|
||||
|
||||
function TValueHelper.AsAnsiString: AnsiString;
|
||||
begin
|
||||
Result := AnsiString(AsString);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
function CopyValue({$ifdef fpc}constref{$else}const [ref]{$endif} aValue: TValue): TValue;
|
||||
var
|
||||
arrptr: Pointer;
|
||||
len, i: SizeInt;
|
||||
begin
|
||||
if aValue.Kind = tkDynArray then begin
|
||||
{ we need to decouple the source reference, so we're going to be a bit
|
||||
cheeky here }
|
||||
len := aValue.GetArrayLength;
|
||||
arrptr := Nil;
|
||||
DynArraySetLength(arrptr, aValue.TypeInfo, 1, @len);
|
||||
TValue.Make(@arrptr, aValue.TypeInfo, Result);
|
||||
for i := 0 to len - 1 do
|
||||
Result.SetArrayElement(i, aValue.GetArrayElement(i));
|
||||
end else
|
||||
TValue.Make(aValue.GetReferenceToRawData, aValue.TypeInfo, Result);
|
||||
end;
|
||||
|
||||
function EqualValues({$ifdef fpc}constref{$else}const [ref]{$endif} aValue1, aValue2: TValue): Boolean;
|
||||
var
|
||||
td1, td2: PTypeData;
|
||||
i: SizeInt;
|
||||
begin
|
||||
{$ifdef debug}
|
||||
Writeln('Empty: ', aValue1.IsEmpty, ' ', aValue2.IsEmpty);
|
||||
Writeln('Kind: ', aValue1.Kind, ' ', aValue2.Kind);
|
||||
Writeln('Array: ', aValue1.IsArray, ' ', aValue2.IsArray);
|
||||
{$endif}
|
||||
if aValue1.IsEmpty and aValue2.IsEmpty then
|
||||
Result := True
|
||||
else if aValue1.IsEmpty and not aValue2.IsEmpty then
|
||||
Result := False
|
||||
else if not aValue1.IsEmpty and aValue2.IsEmpty then
|
||||
Result := False
|
||||
else if aValue1.IsArray and aValue2.IsArray then begin
|
||||
if aValue1.GetArrayLength = aValue2.GetArrayLength then begin
|
||||
Result := True;
|
||||
for i := 0 to aValue1.GetArrayLength - 1 do
|
||||
if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin
|
||||
Writeln('Element ', i, ' differs: ', HexStr(aValue1.GetArrayElement(i).AsOrdinal, 4), ' ', HexStr(aValue2.GetArrayElement(i).AsOrdinal, 4));
|
||||
Result := False;
|
||||
Break;
|
||||
end;
|
||||
end else
|
||||
Result := False;
|
||||
end else if aValue1.Kind = aValue2.Kind then begin
|
||||
td1 := aValue1.TypeData;
|
||||
td2 := aValue2.TypeData;
|
||||
case aValue1.Kind of
|
||||
tkBool:
|
||||
Result := aValue1.AsBoolean xor not aValue2.AsBoolean;
|
||||
tkSet:
|
||||
if td1^.SetSize = td2^.SetSize then
|
||||
if td1^.SetSize < SizeOf(SizeInt) then
|
||||
Result := aValue1.AsOrdinal = aValue2.AsOrdinal
|
||||
else
|
||||
Result := CompareMem(aValue1.GetReferenceToRawData, aValue2.GetReferenceToRawData, td1^.SetSize)
|
||||
else
|
||||
Result := False;
|
||||
tkEnumeration,
|
||||
tkChar,
|
||||
tkWChar,
|
||||
tkUChar,
|
||||
tkInt64,
|
||||
tkInteger:
|
||||
Result := aValue1.AsOrdinal = aValue2.AsOrdinal;
|
||||
tkQWord:
|
||||
Result := aValue1.AsUInt64 = aValue2.AsUInt64;
|
||||
tkFloat:
|
||||
if td1^.FloatType <> td2^.FloatType then
|
||||
Result := False
|
||||
else begin
|
||||
case td1^.FloatType of
|
||||
ftSingle,
|
||||
ftDouble,
|
||||
ftExtended:
|
||||
Result := aValue1.AsExtended = aValue2.AsExtended;
|
||||
ftComp:
|
||||
Result := aValue1.AsInt64 = aValue2.AsInt64;
|
||||
ftCurr:
|
||||
Result := aValue1.AsCurrency = aValue2.AsCurrency;
|
||||
end;
|
||||
end;
|
||||
tkSString,
|
||||
tkUString,
|
||||
tkAString,
|
||||
tkWString:
|
||||
Result := aValue1.AsString = aValue2.AsString;
|
||||
tkDynArray,
|
||||
tkArray:
|
||||
if aValue1.GetArrayLength = aValue2.GetArrayLength then begin
|
||||
Result := True;
|
||||
for i := 0 to aValue1.GetArrayLength - 1 do
|
||||
if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin
|
||||
Result := False;
|
||||
Break;
|
||||
end;
|
||||
end else
|
||||
Result := False;
|
||||
tkClass,
|
||||
tkClassRef,
|
||||
tkInterface,
|
||||
tkInterfaceRaw,
|
||||
tkPointer:
|
||||
Result := PPointer(aValue1.GetReferenceToRawData)^ = PPointer(aValue2.GetReferenceToRawData)^;
|
||||
tkProcVar:
|
||||
Result := PCodePointer(aValue1.GetReferenceToRawData)^ = PCodePointer(aValue2.GetReferenceToRawData)^;
|
||||
tkRecord,
|
||||
tkObject,
|
||||
tkMethod,
|
||||
tkVariant: begin
|
||||
if aValue1.DataSize = aValue2.DataSize then
|
||||
Result := CompareMem(aValue1.GetReferenceToRawData, aValue2.GetReferenceToRawData, aValue1.DataSize)
|
||||
else
|
||||
Result := False;
|
||||
end
|
||||
else
|
||||
Result := False;
|
||||
end;
|
||||
end else
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
function GetIntValue(aValue: SizeInt): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<SizeInt>(aValue);
|
||||
end;
|
||||
|
||||
function GetAnsiString(const aValue: AnsiString): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>(aValue);
|
||||
end;
|
||||
|
||||
function GetShortString(const aValue: ShortString): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<ShortString>(aValue);
|
||||
end;
|
||||
|
||||
function GetSingleValue(aValue: Single): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<Single>(aValue);
|
||||
end;
|
||||
|
||||
function GetDoubleValue(aValue: Double): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<Double>(aValue);
|
||||
end;
|
||||
|
||||
function GetExtendedValue(aValue: Extended): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<Extended>(aValue);
|
||||
end;
|
||||
|
||||
function GetCompValue(aValue: Comp): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<Comp>(aValue);
|
||||
end;
|
||||
|
||||
function GetCurrencyValue(aValue: Currency): TValue;
|
||||
begin
|
||||
Result := TValue.{$ifdef fpc}specialize{$endif}From<Currency>(aValue);
|
||||
end;
|
||||
|
||||
{$ifdef fpc}
|
||||
function GetArray(const aArg: array of SizeInt): TValue;
|
||||
begin
|
||||
Result := specialize OpenArrayToDynArrayValue<SizeInt>(aArg);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
end.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user