pastojs: shortrefglobals: proc var of generic method

git-svn-id: trunk@47277 -

packages/pastojs/src/fppas2js.pp

@@ -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;

packages/pastojs/tests/tcoptimizations.pas

@@ -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:[email protected]<Word>;',
+  '  f:[email protected]<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:[email protected] Fly<Word>;',
+  '  F:[email protected];',
+  '  F:[email protected] 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:[email protected] Fly<Word>;',
+  '  f:[email protected];',
+  '  f:[email protected] 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]);