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

pastojs: fixed call inherited of nested class

Browse Source
This commit is contained in:
mattias 2022-05-22 19:56:39 +02:00
parent db9375d23f
commit bcea5581de
2 changed files with 76 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -25437,24 +25437,17 @@ var
procedure PrependClassOrRecName(var Path: string; ClassOrRec: TPasMembersType);
begin
if (ClassOrRec.ClassType=TPasClassType) and TPasClassType(ClassOrRec).IsExternal then
Prepend(Path,TPasClassType(ClassOrRec).ExternalName)
repeat
Prepend(Path,TPasClassType(ClassOrRec).ExternalName);
if ClassOrRec.Parent.ClassType=TPasClassType then
ClassOrRec := ClassOrRec.Parent as TPasClassType
else
break;
until false
else
Prepend(Path,CreateGlobalTypePath(ClassOrRec,AContext));
end;
procedure PrependClassOrRecNameFullPath(var Path: string; ClassOrRec: TPasMembersType);
begin
while True do
begin
PrependClassOrRecName(Path, ClassOrRec);
if ClassOrRec.Parent.ClassType=TPasClassType then
ClassOrRec := ClassOrRec.Parent as TPasClassType
else
Break;
end;
end;
function NeedsWithExpr: boolean;
var
Parent: TPasElement;
@ -25673,7 +25666,7 @@ begin
// an external class -> use the literal
Result:=TPasClassType(El).ExternalName;
if El.Parent is TPasMembersType then
PrependClassOrRecNameFullPath(Result,TPasMembersType(El.Parent));
PrependClassOrRecName(Result,TPasMembersType(El.Parent));
exit;
end
else if NeedsWithExpr then
@ -25743,7 +25736,7 @@ begin
if Full then
begin
PrependClassOrRecNameFullPath(Result,TPasMembersType(ParentEl));
PrependClassOrRecName(Result,TPasMembersType(ParentEl));
break;
end;

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

@ -635,6 +635,7 @@ type
Procedure TestNestedClass_Alias;
Procedure TestNestedClass_Record;
Procedure TestNestedClass_Class;
Procedure TestNestedClass_CallInherited;
// external class
Procedure TestExternalClass_Var;
@ -18168,7 +18169,6 @@ end;
procedure TTestModule.TestNestedClass_Class;
begin
WithTypeInfo:=true;
StartProgram(false);
Add([
'type',
@ -18254,6 +18254,72 @@ begin
'']));
end;
procedure TTestModule.TestNestedClass_CallInherited;
begin
StartProgram(false);
Add([
'type',
' TObject = class end;',
' TBird = class',
' type',
' TWing = class',
' function Fly(w: word = 17): word; virtual;',
' end;',
' end;',
' TEagle = class(TBird)',
' type',
' TEagleWing = class(TWing)',
' function Fly(w: word): word; override;',
' end;',
' end;',
'function TBird.TWing.Fly(w: word): word;',
'begin',
'end;',
'function TEagle.TEagleWing.Fly(w: word): word;',
'begin',
' inherited;',
' inherited Fly;',
' inherited Fly(3);',
' Result:=inherited Fly;',
' Result:=inherited Fly(4);',
'end;',
'begin',
'']);
ConvertProgram;
CheckSource('TestNestedClass_CallInherited',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
'});',
'rtl.createClass(this, "TBird", this.TObject, function () {',
' rtl.createClass(this, "TWing", $mod.TObject, function () {',
' this.Fly = function (w) {',
' var Result = 0;',
' return Result;',
' };',
' }, "TBird.TWing");',
'});',
'rtl.createClass(this, "TEagle", this.TBird, function () {',
' rtl.createClass(this, "TEagleWing", this.TWing, function () {',
' this.Fly = function (w) {',
' var Result = 0;',
' $mod.TBird.TWing.Fly.apply(this, arguments);',
' $mod.TBird.TWing.Fly.call(this, 17);',
' $mod.TBird.TWing.Fly.call(this, 3);',
' Result = $mod.TBird.TWing.Fly.call(this, 17);',
' Result = $mod.TBird.TWing.Fly.call(this, 4);',
' return Result;',
' };',
' }, "TEagle.TEagleWing");',
'});',
'']),
LinesToStr([ // $mod.$main
'']));
end;
procedure TTestModule.TestExternalClass_Var;
begin
StartProgram(false);