paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-05 11:49:32 +01:00
Code Issues Packages Projects Releases Wiki Activity

pastojs: class in implementation

Browse Source 
git-svn-id: trunk@35919 -
This commit is contained in:
Mattias Gaertner 2017-04-23 14:15:19 +00:00
parent 3daee62509
commit f95be9c80d
2 changed files with 73 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -7430,6 +7430,9 @@ begin
Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],FBuiltInNames[pbifnCreateClass]]); Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],FBuiltInNames[pbifnCreateClass]]);
// add parameter: owner. For top level class, the module is the owner. // add parameter: owner. For top level class, the module is the owner.
if El.Parent is TImplementationSection then
OwnerName:=AContext.GetLocalName(El.Parent)
else
OwnerName:=AContext.GetLocalName(El.GetModule); OwnerName:=AContext.GetLocalName(El.GetModule);
if OwnerName='' then if OwnerName='' then
OwnerName:='this'; OwnerName:='this';

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

@ -321,6 +321,7 @@ type
Procedure TestClass_TObjectConstructorWithParams; Procedure TestClass_TObjectConstructorWithParams;
Procedure TestClass_Var; Procedure TestClass_Var;
Procedure TestClass_Method; Procedure TestClass_Method;
Procedure TestClass_Implementation;
Procedure TestClass_Inheritance; Procedure TestClass_Inheritance;
Procedure TestClass_AbstractMethod; Procedure TestClass_AbstractMethod;
Procedure TestClass_CallInherited_NoParams; Procedure TestClass_CallInherited_NoParams;
@ -5942,6 +5943,74 @@ begin
])); ]));
end; end;
procedure TTestModule.TestClass_Implementation;
begin
StartUnit(false);
Add([
'interface',
'type',
' TObject = class',
' constructor Create;',
' end;',
'implementation',
'type',
' TIntClass = class',
' constructor Create; reintroduce;',
' class procedure DoGlob;',
' end;',
'constructor tintclass.create;',
'begin',
' inherited;',
' inherited create;',
' doglob;',
'end;',
'class procedure tintclass.doglob;',
'begin',
'end;',
'constructor tobject.create;',
'var',
' iC: tintclass;',
'begin',
' ic:=tintclass.create;',
' tintclass.doglob;',
' ic.doglob;',
'end;',
'initialization',
' tintclass.doglob;',
'']);
ConvertUnit;
CheckSource('TestClass_Implementation',
LinesToStr([ // statements
'var $impl = $mod.$impl;',
'rtl.createClass($mod, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
' this.Create = function () {',
' var iC = null;',
' iC = $impl.TIntClass.$create("Create$1");',
' $impl.TIntClass.DoGlob();',
' iC.$class.DoGlob();',
' };',
'});',
'']),
LinesToStr([ // $mod.$main
'$impl.TIntClass.DoGlob();',
'']),
LinesToStr([
'rtl.createClass($impl, "TIntClass", $mod.TObject, function () {',
' this.Create$1 = function () {',
' $mod.TObject.Create.apply(this, arguments);',
' $mod.TObject.Create.call(this);',
' this.$class.DoGlob();',
' };',
' this.DoGlob = function () {',
' };',
'});',
'']));
end;
procedure TTestModule.TestClass_Inheritance; procedure TTestModule.TestClass_Inheritance;
begin begin
StartProgram(false); StartProgram(false);