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

pastojs: shortrefglobals: proc var of generic method

Browse Source 
git-svn-id: trunk@47277 -
This commit is contained in:
Mattias Gaertner 2020-11-02 01:27:07 +00:00
parent 8fe5a1e894
commit 088aacfb26
2 changed files with 218 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -18723,8 +18723,7 @@ begin
aResolver:=AContext.Resolver;
Proc:=TPasProcedure(ResolvedEl.IdentEl);
if (not (Proc.Parent is TPasMembersType))
or (ptmStatic in Proc.ProcType.Modifiers) then
if not aResolver.ProcHasSelf(Proc) then
begin
// not an "of object" method -> simply use the function
Result:=CreateReferencePathExpr(Proc,AContext);
@ -18735,6 +18734,9 @@ begin
IsHelper:=aResolver.IsHelperMethod(Proc);
NeedClass:=aResolver.IsClassMethod(Proc) and not aResolver.MethodIsStatic(Proc);
if Expr is TInlineSpecializeExpr then
Expr:=TInlineSpecializeExpr(Expr).NameExpr;
// an of-object method -> create "rtl.createCallback(Target,func)"
TargetJS:=nil;
Call:=nil;
@ -18819,8 +18821,17 @@ begin
else
begin
// create rtl.createCallback(target, "FunName")
FunName:=TransformElToJSName(Proc,AContext);
Call.AddArg(CreateLiteralString(Expr,FunName));
if (coShortRefGlobals in Options)
and (TPas2JSProcedureScope(Proc.CustomData).SpecializedFromItem<>nil) then
begin
FunName:=CreateStaticProcPath(Proc,AContext);
Call.AddArg(CreatePrimitiveDotExpr(FunName,Expr));
end
else
begin
FunName:=TransformElToJSName(Proc,AContext);
Call.AddArg(CreateLiteralString(Expr,FunName));
end;
end;
Result:=Call;

205
packages/pastojs/tests/tcoptimizations.pas
View File

@ -66,6 +66,8 @@ type
procedure TestOptShortRefGlobals_GenericStaticMethod_Call;
// ToDo: GenericMethod_CallInherited ObjFPC+Delphi
// ToDo: procedure TestOptShortRefGlobals_GenericHelperMethod_Call_Delphi;
procedure TestOptShortRefGlobals_GenericMethod_ProcVar;
procedure TestOptShortRefGlobals_GenericStaticMethod_ProcVar;
// ToDo: proc var
procedure TestOptShortRefGlobals_SameUnit_EnumType;
procedure TestOptShortRefGlobals_SameUnit_ClassType;
@ -733,7 +735,6 @@ begin
'interface',
'uses unita;',
'type',
' TFunc = function(a: word): word;',
' TEagle = class(TBird)',
' procedure Test;',
' generic class function Run<T>(c: word = 25): T; static;',
@ -741,7 +742,6 @@ begin
' end;',
'implementation',
'procedure TEagle.Test;',
'var f: TFunc;',
'begin',
' specialize Fly<Word>;',
' specialize Fly<Word>(31);',
@ -838,6 +838,207 @@ begin
'']));
end;
procedure TTestOptimizations.TestOptShortRefGlobals_GenericMethod_ProcVar;
begin
AddModuleWithIntfImplSrc('UnitA.pas',
LinesToStr([
'{$mode delphi}',
'type',
' TBird = class',
' function Fly<T>(a: word = 13): T;',
' class function Jump<T>(b: word = 14): T;',
' end;',
'']),
LinesToStr([
'function TBird.Fly<T>(a: word): T;',
'begin',
'end;',
'class function TBird.Jump<T>(b: word): T;',
'begin',
'end;',
'']));
StartUnit(true,[supTObject]);
Add([
'{$mode delphi}',
'{$optimization JSShortRefGlobals}',
'interface',
'uses unita;',
'type',
' TFunc<T> = function(a: word): T of object;',
' TEagle = class(TBird)',
' procedure Test;',
' function Run<T>(c: word = 25): T;',
' class function Sing<T>(d: word = 26): T;',
' end;',
'implementation',
'procedure TEagle.Test;',
'var f: TFunc<word>;',
'begin',
' f:=@Run<Word>;',
' f:=@Sing<Word>;',
' f:=@Fly<Word>;',
' f:=@Jump<Word>;',
' f:=@Self.Fly<Word>;',
' f:=@Self.Jump<Word>;',
' with Self do begin',
' f:=@Fly<Word>;',
' f:=@Jump<Word>;',
' end;',
'end;',
'function TEagle.Run<T>(c: word): T;',
'begin',
'end;',
'class function TEagle.Sing<T>(d: word): T;',
'var f: TFunc<T>;',
'begin',
' f:=@Jump<T>;',
'end;',
'']);
ConvertUnit;
CheckSource('TestOptShortRefGlobals_GenericMethod_ProcVar',
LinesToStr([
'var $lt = null;',
'var $lp = null;',
'var $lp1 = null;',
'var $lm = pas.UnitA;',
'var $lt1 = $lm.TBird;',
'var $lp2 = $lt1.Fly$G1;',
'var $lp3 = $lt1.Jump$G1;',
'rtl.createClass(this, "TEagle", $lt1, function () {',
' $lt = this;',
' this.Test = function () {',
' var f = null;',
' f = rtl.createCallback(this, $lp);',
' f = rtl.createCallback(this.$class, $lp1);',
' f = rtl.createCallback(this, $lp2);',
' f = rtl.createCallback(this.$class, $lp3);',
' f = rtl.createCallback(this, $lp2);',
' f = rtl.createCallback(this.$class, $lp3);',
' f = rtl.createCallback(this, $lp2);',
' f = rtl.createCallback(this.$class, $lp3);',
' };',
' this.Run$G1 = $lp = function (c) {',
' var Result = 0;',
' return Result;',
' };',
' this.Sing$G1 = $lp1 = function (d) {',
' var Result = 0;',
' var f = null;',
' f = rtl.createCallback(this, $lp3);',
' return Result;',
' };',
'});',
'']),
LinesToStr([
'']),
LinesToStr([
'']));
end;
procedure TTestOptimizations.TestOptShortRefGlobals_GenericStaticMethod_ProcVar;
begin
AddModuleWithIntfImplSrc('UnitA.pas',
LinesToStr([
'type',
' TBird = class',
' generic class function Fly<T>(a: word = 13): T; static;',
' class function Say(a: word = 13): word; static;',
' end;',
'']),
LinesToStr([
'generic class function TBird.Fly<T>(a: word): T;',
'begin',
'end;',
'class function TBird.Say(a: word): word;',
'begin',
'end;',
'']));
StartUnit(true,[supTObject]);
Add([
'{$optimization JSShortRefGlobals}',
'interface',
'uses unita;',
'type',
' TFunc = function(a: word): word;',
' TEagle = class(TBird)',
' procedure Test;',
' generic class function Run<T>(c: word = 25): T; static;',
' class function Lay(c: word = 25): word; static;',
' end;',
'implementation',
'procedure TEagle.Test;',
'var f: TFunc;',
'begin',
' F:=@specialize Fly<Word>;',
' F:=@Say;',
' F:=@specialize Run<Word>;',
' F:=@Lay;',
' F:=@self.specialize Fly<Word>;',
' F:=@self.Say;',
' F:=@self.specialize Run<Word>;',
' with Self do begin',
' F:=@specialize Fly<Word>;',
' F:=@Say;',
' F:=@specialize Run<Word>;',
' end;',
'end;',
'generic class function TEagle.Run<T>(c: word): T;',
'begin',
'end;',
'class function TEagle.Lay(c: word): word;',
'var f: TFunc;',
'begin',
' f:=@TEagle.specialize Fly<Word>;',
' f:=@TEagle.Say;',
' f:=@TEagle.specialize Run<Word>;',
' f:=@Lay;',
'end;',
'']);
ConvertUnit;
CheckSource('TestOptShortRefGlobals_GenericStaticMethod_ProcVar',
LinesToStr([
'var $lt = null;',
'var $lp = null;',
'var $lm = pas.UnitA;',
'var $lt1 = $lm.TBird;',
'var $lp1 = $lt1.Fly$G1;',
'var $lp2 = $lt1.Say;',
'rtl.createClass(this, "TEagle", $lt1, function () {',
' $lt = this;',
' this.Test = function () {',
' var f = null;',
' f = $lp1;',
' f = $lp2;',
' f = $lp;',
' f = $lt.Lay;',
' f = $lp1;',
' f = $lp2;',
' f = $lp;',
' f = $lp1;',
' f = $lp2;',
' f = $lp;',
' };',
' this.Lay = function (c) {',
' var Result = 0;',
' var f = null;',
' f = $lp1;',
' f = $lp2;',
' f = $lp;',
' f = $lt.Lay;',
' return Result;',
' };',
' this.Run$G1 = $lp = function (c) {',
' var Result = 0;',
' return Result;',
' };',
'});',
'']),
LinesToStr([
'']),
LinesToStr([
'']));
end;
procedure TTestOptimizations.TestOptShortRefGlobals_SameUnit_EnumType;
begin
StartUnit(true,[supTObject]);