From 99b07ba896c0f22c2a008ede25a772603c4ba10c Mon Sep 17 00:00:00 2001 From: svenbarth Date: Sat, 29 Dec 2018 19:20:51 +0000 Subject: * move utility code to a separate unit git-svn-id: https://svn.freepascal.org/svn/fpc/trunk@40692 3ad0048d-3df7-0310-abae-a5850022a9f2 --- packages/rtl-objpas/tests/tests.rtti.invoke.pas | 199 +-------------------- packages/rtl-objpas/tests/tests.rtti.util.pas | 221 ++++++++++++++++++++++++ 2 files changed, 223 insertions(+), 197 deletions(-) create mode 100644 packages/rtl-objpas/tests/tests.rtti.util.pas (limited to 'packages/rtl-objpas') diff --git a/packages/rtl-objpas/tests/tests.rtti.invoke.pas b/packages/rtl-objpas/tests/tests.rtti.invoke.pas index 5b102caaa5..b3e063691a 100644 --- a/packages/rtl-objpas/tests/tests.rtti.invoke.pas +++ b/packages/rtl-objpas/tests/tests.rtti.invoke.pas @@ -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(aValue); -end; - -function GetAnsiString(const aValue: AnsiString): TValue; -begin - Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); -end; - -function GetShortString(const aValue: ShortString): TValue; -begin - Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); -end; - -function GetSingleValue(aValue: Single): TValue; -begin - Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); -end; - -function GetDoubleValue(aValue: Double): TValue; -begin - Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); -end; - -function GetExtendedValue(aValue: Extended): TValue; -begin - Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); -end; - -function GetCompValue(aValue: Comp): TValue; -begin - Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); -end; - -function GetCurrencyValue(aValue: Currency): TValue; -begin - Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); -end; - - -{$ifdef fpc} -function GetArray(const aArg: array of SizeInt): TValue; -begin - Result := specialize OpenArrayToDynArrayValue(aArg); -end; -{$endif} - procedure TTestInvoke.TestIntfMethods; begin DoIntfInvoke(1, [], [], TValue.Empty); diff --git a/packages/rtl-objpas/tests/tests.rtti.util.pas b/packages/rtl-objpas/tests/tests.rtti.util.pas new file mode 100644 index 0000000000..5f9899478c --- /dev/null +++ b/packages/rtl-objpas/tests/tests.rtti.util.pas @@ -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(aValue); +end; + +function GetAnsiString(const aValue: AnsiString): TValue; +begin + Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); +end; + +function GetShortString(const aValue: ShortString): TValue; +begin + Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); +end; + +function GetSingleValue(aValue: Single): TValue; +begin + Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); +end; + +function GetDoubleValue(aValue: Double): TValue; +begin + Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); +end; + +function GetExtendedValue(aValue: Extended): TValue; +begin + Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); +end; + +function GetCompValue(aValue: Comp): TValue; +begin + Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); +end; + +function GetCurrencyValue(aValue: Currency): TValue; +begin + Result := TValue.{$ifdef fpc}specialize{$endif}From(aValue); +end; + +{$ifdef fpc} +function GetArray(const aArg: array of SizeInt): TValue; +begin + Result := specialize OpenArrayToDynArrayValue(aArg); +end; +{$endif} + +end. + -- cgit v1.2.1