mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 21:09:24 +02:00
pastojs: helper inherited
git-svn-id: trunk@41244 -
This commit is contained in:
parent
3b87b10904
commit
fce57c5528
@ -376,6 +376,17 @@ Works:
|
||||
- pass as argument
|
||||
- procedure val(const string; var enumtype; out int)
|
||||
- move all local types to global
|
||||
- class helpers:
|
||||
- ancestor
|
||||
- class var,
|
||||
- const
|
||||
- sub type
|
||||
- method, class method, static class method
|
||||
- call methods, @method
|
||||
- constructor
|
||||
- inherited, inherited name
|
||||
- record helpers:
|
||||
- type helpers:
|
||||
|
||||
ToDos:
|
||||
- class helpers, type helpers, record helpers, array helpers
|
||||
@ -8054,6 +8065,8 @@ function TPasToJSConverter.ConvertInheritedExpr(El: TInheritedExpr;
|
||||
end
|
||||
else
|
||||
FunName:=CreateReferencePath(AncestorProc,AContext,rpkPathAndName,true);
|
||||
if AncestorProc.ProcType.Args.Count=0 then
|
||||
Apply:=false;
|
||||
if Apply and (SelfContext=AContext) then
|
||||
// create "ancestor.funcname.apply(this,arguments)"
|
||||
FunName:=FunName+'.apply'
|
||||
|
@ -636,7 +636,7 @@ type
|
||||
Procedure TestClassHelper_ClassOf;
|
||||
Procedure TestClassHelper_MethodRefObjFPC;
|
||||
Procedure TestClassHelper_Constructor;
|
||||
//Procedure TestClassHelper_InheritedObjFPC;
|
||||
Procedure TestClassHelper_InheritedObjFPC;
|
||||
//Procedure TestClassHelper_InheritedDelphi;
|
||||
// todo: TestClassHelper_Property
|
||||
// todo: TestClassHelper_Property_Array
|
||||
@ -11159,7 +11159,7 @@ begin
|
||||
LinesToStr([
|
||||
'rtl.createClass($impl, "TIntClass", $mod.TObject, function () {',
|
||||
' this.Create$1 = function () {',
|
||||
' $mod.TObject.Create.apply(this, arguments);',
|
||||
' $mod.TObject.Create.call(this);',
|
||||
' $mod.TObject.Create.call(this);',
|
||||
' this.$class.DoGlob();',
|
||||
' return this;',
|
||||
@ -11352,7 +11352,7 @@ begin
|
||||
' $mod.TObject.DoVirtual.call(this);',
|
||||
' };',
|
||||
' this.DoVirtual = function () {',
|
||||
' $mod.TObject.DoVirtual.apply(this, arguments);',
|
||||
' $mod.TObject.DoVirtual.call(this);',
|
||||
' $mod.TObject.DoVirtual.call(this);',
|
||||
' $mod.TObject.DoVirtual.call(this);',
|
||||
' this.DoIt();',
|
||||
@ -11529,7 +11529,7 @@ begin
|
||||
'});',
|
||||
'rtl.createClass($mod, "TA", $mod.TObject, function () {',
|
||||
' this.Create = function () {',
|
||||
' $mod.TObject.Create.apply(this, arguments);',
|
||||
' $mod.TObject.Create.call(this);',
|
||||
' $mod.TObject.Create.call(this);',
|
||||
' $mod.TObject.CreateWithB.call(this, false);',
|
||||
' return this;',
|
||||
@ -17547,7 +17547,7 @@ begin
|
||||
' var $ir = rtl.createIntfRefs();',
|
||||
' var $ok = false;',
|
||||
' try {',
|
||||
' $ir.ref(1, $mod.TObject.GetIntf.apply(this, arguments));',
|
||||
' $ir.ref(1, $mod.TObject.GetIntf.call(this));',
|
||||
' $ir.ref(2, $mod.TObject.GetIntf.call(this));',
|
||||
' $ir.ref(3, $mod.TObject.GetIntf.call(this));',
|
||||
' Result = rtl.setIntfL(Result, $mod.TObject.GetIntf.call(this), true);',
|
||||
@ -19287,6 +19287,108 @@ begin
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestClassHelper_InheritedObjFPC;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'type',
|
||||
' TObject = class',
|
||||
' procedure Fly;',
|
||||
' end;',
|
||||
' TObjHelper = class helper for TObject',
|
||||
' procedure Fly;',
|
||||
' end;',
|
||||
' TBird = class',
|
||||
' procedure Fly;',
|
||||
' end;',
|
||||
' TBirdHelper = class helper for TBird',
|
||||
' procedure Fly;',
|
||||
' procedure Walk;',
|
||||
' end;',
|
||||
' TEagleHelper = class helper(TBirdHelper) for TBird',
|
||||
' procedure Fly;',
|
||||
' procedure Walk;',
|
||||
' end;',
|
||||
'procedure Tobject.fly;',
|
||||
'begin',
|
||||
' inherited;', // ignore
|
||||
'end;',
|
||||
'procedure Tobjhelper.fly;',
|
||||
'begin',
|
||||
' {@TObject_Fly}inherited;',
|
||||
' inherited {@TObject_Fly}Fly;',
|
||||
'end;',
|
||||
'procedure Tbird.fly;',
|
||||
'begin',
|
||||
' {@TObjHelper_Fly}inherited;',
|
||||
' inherited {@TObjHelper_Fly}Fly;',
|
||||
'end;',
|
||||
'procedure Tbirdhelper.fly;',
|
||||
'begin',
|
||||
' {@TBird_Fly}inherited;',
|
||||
' inherited {@TBird_Fly}Fly;',
|
||||
'end;',
|
||||
'procedure Tbirdhelper.walk;',
|
||||
'begin',
|
||||
'end;',
|
||||
'procedure teagleHelper.fly;',
|
||||
'begin',
|
||||
' {@TBird_Fly}inherited;',
|
||||
' inherited {@TBird_Fly}Fly;',
|
||||
'end;',
|
||||
'procedure teagleHelper.walk;',
|
||||
'begin',
|
||||
' {@TBirdHelper_Walk}inherited;',
|
||||
' inherited {@TBirdHelper_Walk}Walk;',
|
||||
'end;',
|
||||
'begin',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestClassHelper_InheritedObjFPC',
|
||||
LinesToStr([ // statements
|
||||
'rtl.createClass($mod, "TObject", null, function () {',
|
||||
' this.$init = function () {',
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' };',
|
||||
' this.Fly = function () {',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createHelper($mod, "TObjHelper", null, function () {',
|
||||
' this.Fly = function () {',
|
||||
' $mod.TObject.Fly.call(this);',
|
||||
' $mod.TObject.Fly.call(this);',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
||||
' this.Fly$1 = function () {',
|
||||
' $mod.TObjHelper.Fly.call(this);',
|
||||
' $mod.TObjHelper.Fly.call(this);',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createHelper($mod, "TBirdHelper", null, function () {',
|
||||
' this.Fly = function () {',
|
||||
' $mod.TBird.Fly$1.call(this);',
|
||||
' $mod.TBird.Fly$1.call(this);',
|
||||
' };',
|
||||
' this.Walk = function () {',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createHelper($mod, "TEagleHelper", $mod.TBirdHelper, function () {',
|
||||
' this.Fly$1 = function () {',
|
||||
' $mod.TBird.Fly$1.call(this);',
|
||||
' $mod.TBird.Fly$1.call(this);',
|
||||
' };',
|
||||
' this.Walk$1 = function () {',
|
||||
' $mod.TBirdHelper.Walk.call(this);',
|
||||
' $mod.TBirdHelper.Walk.call(this);',
|
||||
' };',
|
||||
'});',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestProcType;
|
||||
begin
|
||||
StartProgram(false);
|
||||
|
@ -763,7 +763,7 @@ begin
|
||||
'});',
|
||||
' rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
|
||||
' this.DoA$1 = function () {',
|
||||
' $mod.TObject.DoA.apply(this, arguments);',
|
||||
' $mod.TObject.DoA.call(this);',
|
||||
' };',
|
||||
' this.DoC = function () {',
|
||||
' $mod.TObject.DoB.call(this);',
|
||||
|
Loading…
Reference in New Issue
Block a user