From dd3581a9acab14f1d71da9f8ad22f8728d767ed5 Mon Sep 17 00:00:00 2001
From: mattias <mattias@idefix.freepascal.org>
Date: Sat, 25 Apr 2020 13:54:47 +0000
Subject: [PATCH] fcl-passrc: allow static directive repetition in method
 implementation

---
 .../packages/fcl-passrc/src/pasresolveeval.pas |  2 ++
 .../packages/fcl-passrc/src/pasresolver.pp     | 15 ++++++++++++---
 .../packages/fcl-passrc/tests/tcresolver.pas   | 18 +++++++++++++++++-
 3 files changed, 31 insertions(+), 4 deletions(-)

diff --git a/compiler/packages/fcl-passrc/src/pasresolveeval.pas b/compiler/packages/fcl-passrc/src/pasresolveeval.pas
index 3ac9aa8..76ee7e8 100644
--- a/compiler/packages/fcl-passrc/src/pasresolveeval.pas
+++ b/compiler/packages/fcl-passrc/src/pasresolveeval.pas
@@ -186,6 +186,7 @@ const
   nWrongTypeXInArrayConstructor = 3120;
   nMethodHidesNonVirtualMethodExactly = 3125;
   nDuplicatePublishedMethodXAtY = 3126;
+  nDirectiveXNotAllowedHere = 3143;
 
   // using same IDs as FPC
   nVirtualMethodXHasLowerVisibility = 3250; // was 3050
@@ -319,6 +320,7 @@ resourcestring
   sWrongTypeXInArrayConstructor = 'Wrong type "%s" in array constructor';
   sMethodHidesNonVirtualMethodExactly = 'method hides identifier at "%s". Use reintroduce';
   sDuplicatePublishedMethodXAtY = 'Duplicate published method "%s" at %s';
+  sDirectiveXNotAllowedHere = 'Directive "%s" not allowed here';
 
 type
   { TResolveData - base class for data stored in TPasElement.CustomData }
diff --git a/compiler/packages/fcl-passrc/src/pasresolver.pp b/compiler/packages/fcl-passrc/src/pasresolver.pp
index 2d97413..82b1377 100644
--- a/compiler/packages/fcl-passrc/src/pasresolver.pp
+++ b/compiler/packages/fcl-passrc/src/pasresolver.pp
@@ -6026,7 +6026,7 @@ begin
         RaiseInvalidProcModifier(20170216151637,Proc,pmOverride,Proc);
       if Proc.IsMessage then
         RaiseInvalidProcModifier(20170216151638,Proc,pmMessage,Proc);
-      if Proc.IsStatic then
+      if Proc.IsStatic and not HasDots then
         RaiseInvalidProcTypeModifier(20170216151640,El,ptmStatic,El);
       if (not HasDots)
           and (Proc.GetProcTypeEnum in [
@@ -7943,11 +7943,11 @@ var
   DeclArgs, ImplArgs: TFPList;
   DeclName, ImplName: String;
   ImplResult, DeclResult: TPasType;
+  NewImplPTMods: TProcTypeModifiers;
+  ptm: TProcTypeModifier;
 begin
   if ImplProc.ClassType<>DeclProc.ClassType then
     RaiseXExpectedButYFound(20170216151729,DeclProc.TypeName,ImplProc.TypeName,ImplProc);
-  if ImplProc.CallingConvention<>DeclProc.CallingConvention then
-    RaiseMsg(20170216151731,nCallingConventionMismatch,sCallingConventionMismatch,[],ImplProc);
   if ImplProc.ProcType is TPasFunctionType then
     begin
     // check result type
@@ -7973,6 +7973,15 @@ begin
           sFunctionHeaderMismatchForwardVarName,[DeclProc.Name,DeclName,ImplName],ImplProc);
       end;
     end;
+
+  // modifiers
+  if ImplProc.CallingConvention<>DeclProc.CallingConvention then
+    RaiseMsg(20170216151731,nCallingConventionMismatch,sCallingConventionMismatch,[],ImplProc);
+  NewImplPTMods:=ImplProc.ProcType.Modifiers-DeclProc.ProcType.Modifiers;
+  if NewImplPTMods<>[] then
+    for ptm in NewImplPTMods do
+      RaiseMsg(20200425154821,nDirectiveXNotAllowedHere,sDirectiveXNotAllowedHere,
+        [ProcTypeModifiers[ptm]],ImplProc.ProcType);
 end;
 
 procedure TPasResolver.ResolveImplBlock(Block: TPasImplBlock);
diff --git a/compiler/packages/fcl-passrc/tests/tcresolver.pas b/compiler/packages/fcl-passrc/tests/tcresolver.pas
index acba75b..5005d34 100644
--- a/compiler/packages/fcl-passrc/tests/tcresolver.pas
+++ b/compiler/packages/fcl-passrc/tests/tcresolver.pas
@@ -593,6 +593,7 @@ type
     Procedure TestClass_StaticWithoutClassFail;
     Procedure TestClass_SelfInStaticFail;
     Procedure TestClass_SelfDotInStaticFail;
+    Procedure TestClass_ProcStaticMismatchFail;
     Procedure TestClass_PrivateProtectedInSameUnit;
     Procedure TestClass_PrivateInMainBeginFail;
     Procedure TestClass_PrivateInDescendantFail;
@@ -8382,7 +8383,7 @@ begin
   'begin',
   '  w:=w+1;',
   'end;',
-  'class procedure TRec.Create;',
+  'class procedure TRec.Create; static;',
   'begin',
   '  w:=w+1;',
   'end;',
@@ -10254,6 +10255,21 @@ begin
   CheckResolverException('identifier not found "Self"',nIdentifierNotFound);
 end;
 
+procedure TTestResolver.TestClass_ProcStaticMismatchFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    procedure Run;',
+  '  end;',
+  'procedure TObject.Run; static;',
+  'begin',
+  'end;',
+  'begin']);
+  CheckResolverException('Directive "static" not allowed here',nDirectiveXNotAllowedHere);
+end;
+
 procedure TTestResolver.TestClass_PrivateProtectedInSameUnit;
 begin
   StartProgram(false);