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

pastojs: fixed override method of class interface

Browse Source 
git-svn-id: trunk@39547 -
This commit is contained in:
Mattias Gaertner 2018-08-02 11:19:19 +00:00
parent 11fc60c213
commit e5cc0731ec
3 changed files with 71 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
packages/pastojs/src/fppas2js.pp
View File

@ -11221,9 +11221,14 @@ var
Intf: TPasType; Intf: TPasType;
CurEl: TPasClassType; CurEl: TPasClassType;
begin begin
if El.Interfaces.Count=0 then exit; CurEl:=El;
IntfMaps:=nil; while CurEl.Interfaces.Count=0 do
begin
CurEl:=TPasClassType(AContext.Resolver.GetPasClassAncestor(CurEl,true));
if CurEl=nil then exit; // class and ancestor has no interfaces
end;
IntfMaps:=nil;
FinishedGUIDs:=TStringList.Create; FinishedGUIDs:=TStringList.Create;
try try

1
packages/pastojs/tests/tcfiler.pas
View File

@ -339,6 +339,7 @@ begin
end; end;
try try
PCU:='';
SetLength(PCU,ms.Size); SetLength(PCU,ms.Size);
System.Move(ms.Memory^,PCU[1],length(PCU)); System.Move(ms.Memory^,PCU[1],length(PCU));

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

@ -561,6 +561,7 @@ type
Procedure TestClassInterface_ImplReintroduce; Procedure TestClassInterface_ImplReintroduce;
Procedure TestClassInterface_MethodResolution; Procedure TestClassInterface_MethodResolution;
Procedure TestClassInterface_AncestorMoreInterfaces; Procedure TestClassInterface_AncestorMoreInterfaces;
Procedure TestClassInterface_MethodOverride;
Procedure TestClassInterface_Corba_Delegation; Procedure TestClassInterface_Corba_Delegation;
Procedure TestClassInterface_Corba_DelegationStatic; Procedure TestClassInterface_Corba_DelegationStatic;
Procedure TestClassInterface_Corba_Operators; Procedure TestClassInterface_Corba_Operators;
@ -14828,6 +14829,68 @@ begin
''])); '']));
end; end;
procedure TTestModule.TestClassInterface_MethodOverride;
begin
StartProgram(false);
Add([
'{$interfaces corba}',
'type',
' IUnknown = interface',
' [''{D6D98E5B-8A10-4FEC-856A-7BFC847FE74B}'']',
' procedure Go;',
' end;',
' TObject = class(IUnknown)',
' procedure Go; virtual; abstract;',
' end;',
' TBird = class',
' procedure Go; override;',
' end;',
' TCat = class(TObject)',
' procedure Go; override;',
' end;',
' TDog = class(TObject, IUnknown)',
' procedure Go; override;',
' end;',
'procedure TBird.Go; begin end;',
'procedure TCat.Go; begin end;',
'procedure TDog.Go; begin end;',
'begin',
'']);
ConvertProgram;
CheckSource('TestClassInterface_MethodOverride',
LinesToStr([ // statements
'rtl.createInterface($mod, "IUnknown", "{D6D98E5B-8A10-4FEC-856A-7BFC847FE74B}", ["Go"], null);',
'rtl.createClass($mod, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
' this.$intfmaps = {};',
' rtl.addIntf(this, $mod.IUnknown);',
'});',
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
' this.Go = function () {',
' };',
' this.$intfmaps = {};',
' rtl.addIntf(this, $mod.IUnknown);',
'});',
'rtl.createClass($mod, "TCat", $mod.TObject, function () {',
' this.Go = function () {',
' };',
' this.$intfmaps = {};',
' rtl.addIntf(this, $mod.IUnknown);',
'});',
'rtl.createClass($mod, "TDog", $mod.TObject, function () {',
' this.Go = function () {',
' };',
' this.$intfmaps = {};',
' rtl.addIntf(this, $mod.IUnknown);',
'});',
'']),
LinesToStr([ // $mod.$main
'']));
end;
procedure TTestModule.TestClassInterface_Corba_Delegation; procedure TTestModule.TestClassInterface_Corba_Delegation;
begin begin
StartProgram(false); StartProgram(false);