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

* fix for Mantis #35687: implement TValue.FromOrdinal()

Browse Source 
+ added tests

git-svn-id: trunk@42221 -
This commit is contained in:
svenbarth 2019-06-13 21:08:44 +00:00
parent 34569080be
commit 253f65c5b2
2 changed files with 79 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
packages/rtl-objpas/src/inc/rtti.pp
View File

@ -120,6 +120,7 @@ type
{ Note: a TValue based on an open array is only valid until the routine having the open array parameter is left! }
generic class function FromOpenArray<T>(constref aValue: array of T): TValue; static; inline;
{$endif}
class function FromOrdinal(aTypeInfo: PTypeInfo; aValue: Int64): TValue; static; {inline;}
function IsArray: boolean; inline;
function IsOpenArray: Boolean; inline;
function AsString: string; inline;
@ -1455,6 +1456,15 @@ begin
end;
{$endif}
class function TValue.FromOrdinal(aTypeInfo: PTypeInfo; aValue: Int64): TValue;
begin
if not Assigned(aTypeInfo) or
not (aTypeInfo^.Kind in [tkInteger, tkInt64, tkQWord, tkEnumeration, tkBool, tkChar, tkWChar, tkUChar]) then
raise EInvalidCast.Create(SErrInvalidTypecast);
TValue.Make(@aValue, aTypeInfo, Result);
end;
function TValue.GetIsEmpty: boolean;
begin
result := (FData.FTypeInfo=nil) or

69
packages/rtl-objpas/tests/tests.rtti.pas
View File

@ -64,6 +64,8 @@ type
procedure TestMakeAnsiChar;
procedure TestMakeWideChar;
procedure TestFromOrdinal;
procedure TestDataSize;
procedure TestDataSizeEmpty;
procedure TestReferenceRawData;
@ -81,6 +83,11 @@ type
procedure TestProcVar;
procedure TestMethod;
private
procedure MakeFromOrdinalTObject;
procedure MakeFromOrdinalSet;
procedure MakeFromOrdinalString;
procedure MakeFromOrdinalNil;
end;
implementation
@ -725,6 +732,68 @@ begin
Check(WideChar(v.AsOrdinal) = #$1234);
end;
procedure TTestCase1.MakeFromOrdinalTObject;
begin
TValue.FromOrdinal(TypeInfo(TObject), 42);
end;
procedure TTestCase1.MakeFromOrdinalSet;
begin
TValue.FromOrdinal(TypeInfo(TTestSet), 42);
end;
procedure TTestCase1.MakeFromOrdinalString;
begin
TValue.FromOrdinal(TypeInfo(AnsiString), 42);
end;
procedure TTestCase1.MakeFromOrdinalNil;
begin
TValue.FromOrdinal(Nil, 42);
end;
procedure TTestCase1.TestFromOrdinal;
var
v: TValue;
begin
v := TValue.FromOrdinal(TypeInfo(LongInt), 42);
Check(v.IsOrdinal);
CheckEquals(v.AsOrdinal, 42);
v := TValue.FromOrdinal(TypeInfo(Boolean), Ord(True));
Check(v.IsOrdinal);
CheckEquals(v.AsOrdinal, Ord(True));
v := TValue.FromOrdinal(TypeInfo(Int64), $1234123412341234);
Check(v.IsOrdinal);
CheckEquals(v.AsOrdinal, $1234123412341234);
v := TValue.FromOrdinal(TypeInfo(QWord), $1234123412341234);
Check(v.IsOrdinal);
CheckEquals(v.AsOrdinal, $1234123412341234);
v := TValue.FromOrdinal(TypeInfo(LongBool), Ord(True));
Check(v.IsOrdinal);
CheckEquals(v.AsOrdinal, Ord(True));
v := TValue.FromOrdinal(TypeInfo(TTestEnum), Ord(te1));
Check(v.IsOrdinal);
CheckEquals(v.AsOrdinal, Ord(te1));
v := TValue.FromOrdinal(TypeInfo(AnsiChar), Ord(#20));
Check(v.IsOrdinal);
CheckEquals(v.AsOrdinal, Ord(#20));
v := TValue.FromOrdinal(TypeInfo(WideChar), Ord(#$1234));
Check(v.IsOrdinal);
CheckEquals(v.AsOrdinal, Ord(#$1234));
CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalNil, EInvalidCast);
CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalTObject, EInvalidCast);
CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalSet, EInvalidCast);
CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalString, EInvalidCast);
end;
procedure TTestCase1.TestGetIsReadable;
var
c: TRttiContext;