pastojs: shortrefglobals: call static method

git-svn-id: https://svn.freepascal.org/svn/fpc/trunk@47276 3ad0048d-3df7-0310-abae-a5850022a9f2

5 files changed, 317 insertions, 9 deletions

diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp
index f621a1550a..4fd35e0147 100644
--- a/packages/fcl-passrc/src/pasresolver.pp
+++ b/packages/fcl-passrc/src/pasresolver.pp
@@ -10838,6 +10838,30 @@ procedure TPasResolver.ResolveFuncParamsExprName(NameExpr: TPasExpr;
       end;
   end;
 
+  procedure CheckIncompatibleProc(const CallName: string;
+    FoundProcType: TPasProcedureType; TemplParamsCnt: integer);
+  var
+    FoundTemplCnt: Integer;
+    aName: String;
+  begin
+    CheckCallProcCompatibility(FoundProcType,Params,true);
+    if FoundProcType.GenericTemplateTypes<>nil then
+      FoundTemplCnt:=FoundProcType.GenericTemplateTypes.Count
+    else
+      FoundTemplCnt:=0;
+    if TemplParamsCnt<>FoundTemplCnt then
+      begin
+      if FoundProcType.Parent is TPasProcedure then
+        aName:=FoundProcType.Parent.Name
+      else
+        aName:=FoundProcType.Name;
+      if aName='' then
+        aName:=GetObjPath(FoundProcType);
+      RaiseMsg(20201101205447,nXExpectedButYFound,sXExpectedButYFound,
+               [aName,CallName+GetGenericParamCommas(TemplParamsCnt)],Params);
+      end;
+  end;
+
 var
   FindCallData: TFindCallElData;
   Abort: boolean;
@@ -10882,7 +10906,7 @@ begin
     WriteScopes;
     {$ENDIF}
     if FoundEl is TPasProcedure then
-      CheckCallProcCompatibility(TPasProcedure(FoundEl).ProcType,Params,true)
+      CheckIncompatibleProc(CallName,TPasProcedure(FoundEl).ProcType,TemplParamsCnt)
     else if FoundEl is TPasProcedureType then
       CheckTypeCast(TPasProcedureType(FoundEl),Params,true)
     else if FoundEl.ClassType=TPasUnresolvedSymbolRef then
@@ -10905,7 +10929,7 @@ begin
       begin
       TypeEl:=ResolveAliasType(TPasVariable(FoundEl).VarType);
       if TypeEl is TPasProcedureType then
-        CheckCallProcCompatibility(TPasProcedureType(TypeEl),Params,true)
+        CheckIncompatibleProc(CallName,TPasProcedureType(TypeEl),TemplParamsCnt)
       else
         RaiseMsg(20170405003522,nIllegalQualifierAfter,sIllegalQualifierAfter,
                  ['(',TypeEl.ElementTypeName],Params);
@@ -10914,7 +10938,7 @@ begin
       begin
       TypeEl:=ResolveAliasType(TPasArgument(FoundEl).ArgType);
       if TypeEl is TPasProcedureType then
-        CheckCallProcCompatibility(TPasProcedureType(TypeEl),Params,true)
+        CheckIncompatibleProc(CallName,TPasProcedureType(TypeEl),TemplParamsCnt)
       else
         RaiseMsg(20180228145412,nIllegalQualifierAfter,sIllegalQualifierAfter,
                  ['(',TypeEl.ElementTypeName],Params);
diff --git a/packages/fcl-passrc/tests/tcresolvegenerics.pas b/packages/fcl-passrc/tests/tcresolvegenerics.pas
index d99626dcb0..3fa68192a9 100644
--- a/packages/fcl-passrc/tests/tcresolvegenerics.pas
+++ b/packages/fcl-passrc/tests/tcresolvegenerics.pas
@@ -138,6 +138,7 @@ type
     procedure TestGenProc_FunctionDelphi;
     procedure TestGenProc_OverloadDuplicate;
     procedure TestGenProc_MissingTemplatesFail;
+    procedure TestGenProc_SpecializeNonGenericFail;
     procedure TestGenProc_Forward;
     procedure TestGenProc_External;
     procedure TestGenProc_UnitIntf;
@@ -2216,6 +2217,19 @@ begin
   CheckParserException('Expected "<"',nParserExpectTokenError);
 end;
 
+procedure TTestResolveGenerics.TestGenProc_SpecializeNonGenericFail;
+begin
+  StartProgram(false);
+  Add([
+  'procedure Run;',
+  'begin',
+  'end;',
+  'begin',
+  '  specialize Run<word>();',
+  '']);
+  CheckResolverException('Run expected, but Run<> found',nXExpectedButYFound);
+end;
+
 procedure TTestResolveGenerics.TestGenProc_Forward;
 begin
   StartProgram(false);
diff --git a/packages/fcl-passrc/tests/tcuseanalyzer.pas b/packages/fcl-passrc/tests/tcuseanalyzer.pas
index c8fb81497e..7afa527492 100644
--- a/packages/fcl-passrc/tests/tcuseanalyzer.pas
+++ b/packages/fcl-passrc/tests/tcuseanalyzer.pas
@@ -178,6 +178,7 @@ type
     procedure TestWP_Attributes;
     procedure TestWP_Attributes_ForwardClass;
     procedure TestWP_Attributes_Params;
+    procedure TestWP_Attributes_PublishedFields; // ToDo
 
     // scope references
     procedure TestSR_Proc_UnitVar;
@@ -3471,6 +3472,46 @@ begin
   AnalyzeWholeProgram;
 end;
 
+procedure TTestUseAnalyzer.TestWP_Attributes_PublishedFields;
+begin
+  exit;
+
+  StartProgram(false);
+  Add([
+  '{$modeswitch prefixedattributes}',
+  'type',
+  '  TObject = class',
+  '    constructor {#TObject_Create_notused}Create;',
+  '    destructor {#TObject_Destroy_used}Destroy; virtual;',
+  '  end;',
+  '  {#TCustomAttribute_used}TCustomAttribute = class',
+  '  end;',
+  '  {#BigAttribute_used}BigAttribute = class(TCustomAttribute)',
+  '    constructor {#Big_A_used}Create(Id: word = 3); overload;',
+  '    destructor {#Big_B_used}Destroy; override;',
+  '  end;',
+  '  {$M+}',
+  '  TBird = class',
+  '  public',
+  '    FColor: word;',
+  '  published',
+  '    Size: word;',
+  '    procedure Fly;',
+  '    [Big(3)]',
+  '    property Color: word read FColor;',
+  '  end;',
+  'constructor TObject.Create; begin end;',
+  'destructor TObject.Destroy; begin end;',
+  'constructor BigAttribute.Create(Id: word); begin end;',
+  'destructor BigAttribute.Destroy; begin end;',
+  'var',
+  '  b: TBird;',
+  'begin',
+  '  if typeinfo(b)=nil then ;',
+  '']);
+  AnalyzeWholeProgram;
+end;
+
 procedure TTestUseAnalyzer.TestSR_Proc_UnitVar;
 begin
   StartUnit(false);
diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp
index 59d3df211a..fa3e71d6ab 100644
--- a/packages/pastojs/src/fppas2js.pp
+++ b/packages/pastojs/src/fppas2js.pp
@@ -9519,6 +9519,20 @@ begin
     Result:=CreateDotNameExpr(El,LeftJS,TJSString(TransformElToJSName(RightRefDecl,AContext)));
     exit;
     end;
+  if RightRefDecl is TPasProcedure then
+    begin
+    Proc:=TPasProcedure(RightRefDecl);
+    if coShortRefGlobals in Options then
+      begin
+      if not aResolver.ProcHasSelf(Proc) then
+        begin
+        // a.StaticProc  ->  $lp(defaultargs)
+        // ToDo: check if left side has only types (no call nor field)
+        Result:=ConvertIdentifierExpr(RightEl,TPrimitiveExpr(RightEl).Value,aContext);
+        exit;
+        end;
+      end;
+    end;
 
   LeftJS:=nil;
   if aResolver.IsHelper(RightRefDecl.Parent) then
diff --git a/packages/pastojs/tests/tcoptimizations.pas b/packages/pastojs/tests/tcoptimizations.pas
index b580cf5388..ef1b202157 100644
--- a/packages/pastojs/tests/tcoptimizations.pas
+++ b/packages/pastojs/tests/tcoptimizations.pas
@@ -60,13 +60,11 @@ type
     procedure TestOptShortRefGlobals_Program;
     procedure TestOptShortRefGlobals_Unit_FromIntfImpl_ToIntfImpl;
     procedure TestOptShortRefGlobals_Property;
-    // ToDo: ShortRefGlobals_ExternalAndAbstract ObjFPC+Delphi
+    procedure TestOptShortRefGlobals_ExternalAbstract;
     procedure TestOptShortRefGlobals_GenericFunction;
-    procedure TestOptShortRefGlobals_GenericMethod_Call_ObjFPC;
-    // ToDo: procedure TestOptShortRefGlobals_GenericMethod_Call_Delphi;
-    // ToDo: GenericStaticMethod_Call ObjFPC+Delphi
+    procedure TestOptShortRefGlobals_GenericMethod_Call;
+    procedure TestOptShortRefGlobals_GenericStaticMethod_Call;
     // ToDo: GenericMethod_CallInherited ObjFPC+Delphi
-    // ToDo: GenericMethod_External ObjFPC+Delphi
     // ToDo: procedure TestOptShortRefGlobals_GenericHelperMethod_Call_Delphi;
     // ToDo: proc var
     procedure TestOptShortRefGlobals_SameUnit_EnumType;
@@ -464,6 +462,94 @@ begin
     '']));
 end;
 
+procedure TTestOptimizations.TestOptShortRefGlobals_ExternalAbstract;
+begin
+  AddModuleWithIntfImplSrc('UnitA.pas',
+  LinesToStr([
+    'type',
+    '  TBird = class',
+    '    generic function FlyExt<T>(a: word = 103): T; external name ''Flying'';',
+    '    class procedure JumpVirtual(a: word = 104); virtual; abstract;',
+    '    class procedure RunStaticExt(a: word = 105); static; external name ''Running'';',
+    '  end;',
+    'procedure SayExt(a: word = 106); external name ''Saying'';',
+    '']),
+  LinesToStr([
+    '']));
+  StartUnit(true,[supTObject]);
+  Add([
+  '{$optimization JSShortRefGlobals}',
+  'interface',
+  'uses unita;',
+  'type',
+  '  TEagle = class(TBird)',
+  '    procedure Test;',
+  '  end;',
+  'implementation',
+  'procedure TEagle.Test;',
+  'begin',
+  '  specialize FlyExt<Word>;',
+  '  specialize FlyExt<Word>(1);',
+  '  specialize JumpVirtual;',
+  '  specialize JumpVirtual(2);',
+  '  specialize RunStaticExt;',
+  '  specialize RunStaticExt(3);',
+  '  specialize SayExt;',
+  '  specialize SayExt(4);',
+  '  Self.specialize FlyExt<Word>;',
+  '  Self.specialize FlyExt<Word>(11);',
+  '  Self.specialize JumpVirtual;',
+  '  Self.specialize JumpVirtual(12);',
+  '  Self.specialize RunStaticExt;',
+  '  Self.specialize RunStaticExt(13);',
+  '  with Self do begin',
+  '    specialize FlyExt<Word>;',
+  '    specialize FlyExt<Word>(21);',
+  '    specialize JumpVirtual;',
+  '    specialize JumpVirtual(22);',
+  '    specialize RunStaticExt;',
+  '    specialize RunStaticExt(23);',
+  '  end;',
+  'end;',
+  '']);
+  ConvertUnit;
+  CheckSource('TestOptShortRefGlobals_ExternalAbstract',
+    LinesToStr([
+    'var $lt = null;',
+    'var $lm = pas.UnitA;',
+    'var $lt1 = $lm.TBird;',
+    'rtl.createClass(this, "TEagle", $lt1, function () {',
+    '  $lt = this;',
+    '  this.Test = function () {',
+    '    this.Flying(103);',
+    '    this.Flying(1);',
+    '    this.$class.JumpVirtual(104);',
+    '    this.$class.JumpVirtual(2);',
+    '    this.Running(105);',
+    '    this.Running(3);',
+    '    Saying(106);',
+    '    Saying(4);',
+    '    this.Flying(103);',
+    '    this.Flying(11);',
+    '    this.$class.JumpVirtual(104);',
+    '    this.$class.JumpVirtual(12);',
+    '    this.Running(105);',
+    '    this.Running(13);',
+    '    this.Flying(103);',
+    '    this.Flying(21);',
+    '    this.$class.JumpVirtual(104);',
+    '    this.$class.JumpVirtual(22);',
+    '    this.Running(105);',
+    '    this.Running(23);',
+    '  };',
+    '});',
+    '']),
+    LinesToStr([
+    '']),
+    LinesToStr([
+    '']));
+end;
+
 procedure TTestOptimizations.TestOptShortRefGlobals_GenericFunction;
 begin
   AddModuleWithIntfImplSrc('UnitA.pas',
@@ -511,7 +597,7 @@ begin
     '']));
 end;
 
-procedure TTestOptimizations.TestOptShortRefGlobals_GenericMethod_Call_ObjFPC;
+procedure TTestOptimizations.TestOptShortRefGlobals_GenericMethod_Call;
 begin
   AddModuleWithIntfImplSrc('UnitA.pas',
   LinesToStr([
@@ -623,6 +709,135 @@ begin
     '']));
 end;
 
+procedure TTestOptimizations.TestOptShortRefGlobals_GenericStaticMethod_Call;
+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',
+  '  specialize Fly<Word>;',
+  '  specialize Fly<Word>(31);',
+  '  Say;',
+  '  Say(32);',
+  '  specialize Run<Word>;',
+  '  specialize Run<Word>(33);',
+  '  Lay;',
+  '  Lay(34);',
+  '  self.specialize Fly<Word>;',
+  '  self.specialize Fly<Word>(41);',
+  '  self.Say;',
+  '  self.Say(42);',
+  '  self.specialize Run<Word>;',
+  '  self.specialize Run<Word>(43);',
+  '  with Self do begin',
+  '    specialize Fly<Word>;',
+  '    specialize Fly<Word>(51);',
+  '    Say;',
+  '    Say(52);',
+  '    specialize Run<Word>;',
+  '    specialize Run<Word>(53);',
+  '  end;',
+  'end;',
+  'generic class function TEagle.Run<T>(c: word): T;',
+  'begin',
+  'end;',
+  'class function TEagle.Lay(c: word): word;',
+  'begin',
+  '  TEagle.specialize Fly<Word>;',
+  '  TEagle.specialize Fly<Word>(61);',
+  '  TEagle.Say;',
+  '  TEagle.Say(62);',
+  '  TEagle.specialize Run<Word>;',
+  '  specialize Run<Word>(63);',
+  '  Lay;',
+  '  Lay(64);',
+  'end;',
+  '']);
+  ConvertUnit;
+  CheckSource('TestOptShortRefGlobals_GenericStaticMethod_Call',
+    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 () {',
+    '    $lp1(13);',
+    '    $lp1(31);',
+    '    $lp2(13);',
+    '    $lp2(32);',
+    '    $lp(25);',
+    '    $lp(33);',
+    '    $lt.Lay(25);',
+    '    $lt.Lay(34);',
+    '    $lp1(13);',
+    '    $lp1(41);',
+    '    $lp2(13);',
+    '    $lp2(42);',
+    '    $lp(25);',
+    '    $lp(43);',
+    '    $lp1(13);',
+    '    $lp1(51);',
+    '    $lp2(13);',
+    '    $lp2(52);',
+    '    $lp(25);',
+    '    $lp(53);',
+    '  };',
+    '  this.Lay = function (c) {',
+    '    var Result = 0;',
+    '    $lp1(13);',
+    '    $lp1(61);',
+    '    $lp2(13);',
+    '    $lp2(62);',
+    '    $lp(25);',
+    '    $lp(63);',
+    '    $lt.Lay(25);',
+    '    $lt.Lay(64);',
+    '    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]);