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

fcl-passrc: fixed attributes of interface types issue 39198

Browse Source
This commit is contained in:
mattias 2022-02-04 13:09:56 +01:00
parent 3713784e40
commit 9bf4f9e2ce
2 changed files with 120 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
packages/fcl-passrc/src/pasresolver.pp
View File

@ -29397,6 +29397,11 @@ var
begin begin
Result:=nil; Result:=nil;
if El=nil then exit; if El=nil then exit;
if (El.CustomData is TPasClassScope) and Assigned(TPasClassScope(El.CustomData).SpecializedFromItem) then
Result := GetAttributeCallsEl(TPasClassScope(El.CustomData).SpecializedFromItem.GenericEl)
else
begin
// find El in El.Parent members // find El in El.Parent members
Parent:=El.Parent; Parent:=El.Parent;
if Parent=nil then exit; if Parent=nil then exit;
@ -29407,9 +29412,11 @@ begin
Members:=TPasMembersType(Parent).Members Members:=TPasMembersType(Parent).Members
else else
exit; exit;
i:=Members.IndexOf(El); i:=Members.IndexOf(El);
if i<0 then exit; if i<0 then exit;
Result:=GetAttributeCalls(Members,i); Result:=GetAttributeCalls(Members,i);
end;
end; end;
function TPasResolver.GetAttributeCalls(Members: TFPList; Index: integer function TPasResolver.GetAttributeCalls(Members: TFPList; Index: integer
@ -29460,6 +29467,11 @@ begin
AddAttributesInFront(Members,Index); AddAttributesInFront(Members,Index);
break; break;
end; end;
if CurEl.CustomData is TPasClassScope then
if Assigned(TPasClassScope(CurEl.CustomData).SpecializedFromItem) then
AddAttributesInFront(Members,Index)
else
break;
until false; until false;
end; end;

96
packages/pastojs/tests/tcmodules.pas
View File

@ -871,6 +871,7 @@ type
Procedure TestAttributes_Members; Procedure TestAttributes_Members;
Procedure TestAttributes_Types; Procedure TestAttributes_Types;
Procedure TestAttributes_HelperConstructor_Fail; Procedure TestAttributes_HelperConstructor_Fail;
Procedure TestAttributes_InterfacesList;
// Assertions, checks // Assertions, checks
procedure TestAssert; procedure TestAssert;
@ -32390,6 +32391,101 @@ begin
ConvertProgram; ConvertProgram;
end; end;
procedure TTestModule.TestAttributes_InterfacesList;
begin
WithTypeInfo:=true;
StartProgram(false);
Add([
'{$mode Delphi}',
'type',
' TObject = class',
' constructor Create;',
' end;',
' IInterface = interface end;',
' TCustomAttribute = class',
' end;',
' Red = class(TCustomAttribute);',
' Blue = class(TCustomAttribute);',
' [Red]',
' IBird<T> = interface',
' procedure Fly;',
' end;',
' [Blue]',
' IEagle = interface(IBird<Word>)',
' procedure Dive;',
' end;',
' TAnt = class(TObject, IEagle)',
' procedure Fly; virtual; abstract;',
' procedure Dive; virtual; abstract;',
' end;',
'constructor TObject.Create;',
'begin',
'end;',
'begin',
'']);
ConvertProgram;
CheckSource('TestAttributes_InterfacesList',
LinesToStr([ // statements
'$mod.$rtti.$Interface("IBird<System.Word>");',
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
' this.Create = function () {',
' return this;',
' };',
'});',
'rtl.createInterface(',
' this,',
' "IInterface",',
' "{B92D5841-698D-3153-90C5-000000000000}",',
' [],',
' null,',
' function () {',
' this.$kind = "com";',
' }',
');',
'rtl.createClass(this, "TCustomAttribute", this.TObject, function () {',
'});',
'rtl.createClass(this, "Red", this.TCustomAttribute, function () {',
'});',
'rtl.createClass(this, "Blue", this.TCustomAttribute, function () {',
'});',
'rtl.createInterface(',
' this,',
' "IBird$G1",',
' "{14691591-6648-3574-B8C8-FAAD81DAC421}",',
' ["Fly"],',
' this.IInterface,',
' function () {',
' var $r = this.$rtti;',
' $r.addMethod("Fly", 0, []);',
' $r.attr = [$mod.Red, "Create"];',
' },',
' "IBird<System.Word>"',
');',
'rtl.createInterface(',
' this,',
' "IEagle",',
' "{5F4202AE-F2BE-37FD-8A88-1A2F926F1117}",',
' ["Dive"],',
' this.IBird$G1,',
' function () {',
' var $r = this.$rtti;',
' $r.addMethod("Dive", 0, []);',
' $r.attr = [$mod.Blue, "Create"];',
' }',
');',
'rtl.createClass(this, "TAnt", this.TObject, function () {',
' rtl.addIntf(this, $mod.IEagle);',
'});',
'']),
LinesToStr([ // $mod.$main
'']));
end;
procedure TTestModule.TestAssert; procedure TTestModule.TestAssert;
begin begin
StartProgram(false); StartProgram(false);