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

* use new pool functionality for property instances

Browse Source 
* extended test

git-svn-id: trunk@37418 -
This commit is contained in:
svenbarth 2017-10-07 17:32:28 +00:00
parent 1cbb4266d7
commit d9bc656852
2 changed files with 23 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -284,7 +284,6 @@ type
function GetTypeSize: integer; override; function GetTypeSize: integer; override;
function GetBaseType: TRttiType; override; function GetBaseType: TRttiType; override;
public public
destructor Destroy; override;
function GetProperties: specialize TArray<TRttiProperty>; override; function GetProperties: specialize TArray<TRttiProperty>; override;
property MetaClassType: TClass read GetMetaClassType; property MetaClassType: TClass read GetMetaClassType;
property DeclaringUnitName: string read GetDeclaringUnitName; property DeclaringUnitName: string read GetDeclaringUnitName;
@ -1671,14 +1670,6 @@ begin
Result:=sizeof(TObject); Result:=sizeof(TObject);
end; end;
destructor TRttiInstanceType.Destroy;
var
i: Integer;
begin
for i := 0 to high(FProperties) do
FProperties[i].Free;
end;
function TRttiInstanceType.GetProperties: specialize TArray<TRttiProperty>; function TRttiInstanceType.GetProperties: specialize TArray<TRttiProperty>;
type type
PPropData = ^TPropData; PPropData = ^TPropData;
@ -1689,6 +1680,7 @@ var
PPD: PPropData; PPD: PPropData;
TP: PPropInfo; TP: PPropInfo;
Count: longint; Count: longint;
obj: TRttiObject;
begin begin
if not FPropertiesResolved then if not FPropertiesResolved then
begin begin
@ -1711,8 +1703,15 @@ begin
While Count>0 do While Count>0 do
begin begin
// Don't overwrite properties with the same name // Don't overwrite properties with the same name
if FProperties[TP^.NameIndex]=nil then if FProperties[TP^.NameIndex]=nil then begin
FProperties[TP^.NameIndex]:=TRttiProperty.Create(TypeRttiType, TP); obj := GRttiPool.GetByHandle(TP);
if Assigned(obj) then
FProperties[TP^.NameIndex] := obj as TRttiProperty
else begin
FProperties[TP^.NameIndex] := TRttiProperty.Create(TypeRttiType, TP);
GRttiPool.AddObject(FProperties[TP^.NameIndex]);
end;
end;
// Point to TP next propinfo record. // Point to TP next propinfo record.
// Located at Name[Length(Name)+1] ! // Located at Name[Length(Name)+1] !

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

@ -76,6 +76,10 @@ type
property PubPropSetRO: integer read FPubPropRO; property PubPropSetRO: integer read FPubPropRO;
property PubPropSetRW: integer read FPubPropRW write FPubPropRW; property PubPropSetRW: integer read FPubPropRW write FPubPropRW;
end; end;
TGetClassPropertiesSub = class(TGetClassProperties)
end;
{$M-} {$M-}
{ TTestValueClass } { TTestValueClass }
@ -864,7 +868,8 @@ procedure TTestCase1.GetClassProperties;
var var
LContext: TRttiContext; LContext: TRttiContext;
LType: TRttiType; LType: TRttiType;
PropList: {$ifdef fpc}specialize{$endif} TArray<TRttiProperty>; PropList, PropList2: {$ifdef fpc}specialize{$endif} TArray<TRttiProperty>;
i: LongInt;
begin begin
LContext := TRttiContext.Create; LContext := TRttiContext.Create;
@ -877,6 +882,13 @@ begin
CheckEquals('PubPropSetRO', PropList[2].Name); CheckEquals('PubPropSetRO', PropList[2].Name);
CheckEquals('PubPropSetRW', PropList[3].Name); CheckEquals('PubPropSetRW', PropList[3].Name);
LType := LContext.GetType(TypeInfo(TGetClassPropertiesSub));
PropList2 := LType.GetProperties;
CheckEquals(Length(PropList), Length(PropList2));
for i := 0 to High(PropList) do
Check(PropList[i] = PropList2[i], 'Property instances are not equal');
LContext.Free; LContext.Free;
end; end;