fcl-passrc: resolver: check procedure modifiers of proc body and declration, procedure modifier async

git-svn-id: trunk@45431 -

packages/fcl-passrc/src/pasresolver.pp

@@ -7026,6 +7026,8 @@ begin
             {$ENDIF}
             CheckProcSignatureMatch(DeclProc,Proc,false);
             DeclProcScope.ImplProc:=Proc;
+            if DeclProc.IsAssembler then
+              Proc.Modifiers:=Proc.Modifiers+[pmAssembler];
             ProcScope.DeclarationProc:=DeclProc;
             // remove ImplProc from scope
             ParentScope.RemoveLocalIdentifier(Proc);
@@ -7272,6 +7274,8 @@ begin
     if DeclProc.IsExternal then
       RaiseXExpectedButYFound(20170216151725,'method','external method',ImplProc);
     CheckProcSignatureMatch(DeclProc,ImplProc,false);
+    if DeclProc.IsAssembler then
+      ImplProc.Modifiers:=ImplProc.Modifiers+[pmAssembler];
     ImplProcScope.DeclarationProc:=DeclProc;
     DeclProcScope.ImplProc:=ImplProc;
 
@@ -9209,6 +9213,8 @@ var
   ImplTemplType, DeclTemplType: TPasGenericTemplateType;
   NewImplPTMods: TProcTypeModifiers;
   ptm: TProcTypeModifier;
+  NewImplProcMods: TProcedureModifiers;
+  pm: TProcedureModifier;
 begin
   if ImplProc.ClassType<>DeclProc.ClassType then
     RaiseXExpectedButYFound(20170216151729,DeclProc.TypeName,ImplProc.TypeName,ImplProc);
@@ -9276,10 +9282,24 @@ begin
         [],DeclResult,ImplResult,ImplProc);
     end;
 
-  // modifiers
+  // calling convention
   if ImplProc.CallingConvention<>DeclProc.CallingConvention then
     RaiseMsg(20170216151731,nCallingConventionMismatch,sCallingConventionMismatch,[],ImplProc);
+
+  // proc modifiers
+  NewImplProcMods:=ImplProc.Modifiers-DeclProc.Modifiers-[pmAssembler];
+  if not IsOverride then
+    begin
+    // implementation proc must not add modifiers, except "assembler"
+    if NewImplProcMods<>[] then
+      for pm in NewImplProcMods do
+        RaiseMsg(20200518182445,nDirectiveXNotAllowedHere,sDirectiveXNotAllowedHere,
+          [ModifierNames[pm]],ImplProc.ProcType);
+    end;
+
+  // proc type modifiers
   NewImplPTMods:=ImplProc.ProcType.Modifiers-DeclProc.ProcType.Modifiers;
+  // implementation proc must not add modifiers
   if NewImplPTMods<>[] then
     for ptm in NewImplPTMods do
       RaiseMsg(20200425154821,nDirectiveXNotAllowedHere,sDirectiveXNotAllowedHere,

packages/fcl-passrc/src/pastree.pp

@@ -22,6 +22,7 @@ unit PasTree;
 {$if defined(debugrefcount) or defined(VerbosePasTreeMem) or defined(VerbosePasResolver)}
   {$define EnablePasTreeGlobalRefCount}
 {$endif}
+{$inline on}
 
 interface
 
@@ -646,8 +647,8 @@ type
     Ranges: TPasExprArray; // only valid if Parser po_arrayrangeexpr enabled
     PackMode : TPackMode;
     ElType: TPasType; // nil means array-of-const
-    function IsGenericArray : Boolean;
-    function IsPacked : Boolean;
+    function IsGenericArray : Boolean; inline;
+    function IsPacked : Boolean; inline;
     procedure AddRange(Range: TPasExpr);
   end;
 
@@ -730,8 +731,8 @@ type
     Members: TFPList;
     Constructor Create(const AName: string; AParent: TPasElement); override;
     Destructor Destroy; override;
-    Function IsPacked: Boolean;
-    Function IsBitPacked : Boolean;
+    Function IsPacked: Boolean; inline;
+    Function IsBitPacked : Boolean; inline;
     Procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
       const Arg: Pointer); override;
   end;
@@ -828,9 +829,9 @@ type
 
   TPasProcedureType = class(TPasGenericType)
   private
-    function GetIsNested: Boolean;
-    function GetIsOfObject: Boolean;
-    function GetIsReference: Boolean;
+    function GetIsNested: Boolean; inline;
+    function GetIsOfObject: Boolean; inline;
+    function GetIsReference: Boolean; inline;
     procedure SetIsNested(const AValue: Boolean);
     procedure SetIsOfObject(const AValue: Boolean);
     procedure SetIsReference(AValue: Boolean);
@@ -969,7 +970,7 @@ type
   private
     FArgs: TFPList;
     FResolvedType : TPasType;
-    function GetIsClass: boolean;
+    function GetIsClass: boolean; inline;
     procedure SetIsClass(AValue: boolean);
   public
     constructor Create(const AName: string; AParent: TPasElement); override;
@@ -1043,9 +1044,9 @@ type
 
   TProcedureModifier = (pmVirtual, pmDynamic, pmAbstract, pmOverride,
                         pmExport, pmOverload, pmMessage, pmReintroduce,
-                        pmInline,pmAssembler, pmPublic,
-                        pmCompilerProc,pmExternal,pmForward, pmDispId, 
-                        pmNoReturn, pmFar, pmFinal);
+                        pmInline, pmAssembler, pmPublic,
+                        pmCompilerProc, pmExternal, pmForward, pmDispId,
+                        pmNoReturn, pmFar, pmFinal, pmAsync);
   TProcedureModifiers = Set of TProcedureModifier;
   TProcedureMessageType = (pmtNone,pmtInteger,pmtString);
 
@@ -1087,17 +1088,19 @@ type
     Body : TProcedureBody;
     NameParts: TProcedureNameParts; // only used for generic aka parametrized functions
     Procedure AddModifier(AModifier : TProcedureModifier);
-    Function IsVirtual : Boolean;
-    Function IsDynamic : Boolean;
-    Function IsAbstract : Boolean;
-    Function IsOverride : Boolean;
-    Function IsExported : Boolean;
-    Function IsExternal : Boolean;
-    Function IsOverload : Boolean;
-    Function IsMessage: Boolean;
-    Function IsReintroduced : Boolean;
-    Function IsStatic : Boolean;
-    Function IsForward: Boolean;
+    Function IsVirtual : Boolean; inline;
+    Function IsDynamic : Boolean; inline;
+    Function IsAbstract : Boolean; inline;
+    Function IsOverride : Boolean; inline;
+    Function IsExported : Boolean; inline;
+    Function IsExternal : Boolean; inline;
+    Function IsOverload : Boolean; inline;
+    Function IsMessage: Boolean; inline;
+    Function IsReintroduced : Boolean; inline;
+    Function IsStatic : Boolean; inline;
+    Function IsForward: Boolean; inline;
+    Function IsAssembler: Boolean; inline;
+    Function IsAsync: Boolean; inline;
     Function GetProcTypeEnum: TProcType; virtual;
     procedure SetNameParts(Parts: TProcedureNameParts);
     Property Modifiers : TProcedureModifiers Read FModifiers Write FModifiers;
@@ -1551,7 +1554,7 @@ type
     EndExpr : TPasExpr; // if LoopType=ltIn this is nil
     Body: TPasImplElement;
     Variable: TPasVariable; // not used by TPasParser
-    Function Down: boolean; // downto, backward compatibility
+    Function Down: boolean; inline;// downto, backward compatibility
     Function StartValue : String;
     Function EndValue: string;
   end;
@@ -1739,7 +1742,7 @@ const
                    'export', 'overload', 'message', 'reintroduce',
                    'inline','assembler','public',
                    'compilerproc','external','forward','dispid',
-                   'noreturn','far','final');
+                   'noreturn','far','final','async');
 
   VariableModifierNames : Array[TVariableModifier] of string
      = ('cvar', 'external', 'public', 'export', 'class', 'static');
@@ -4784,6 +4787,16 @@ begin
   Result:=pmForward in FModifiers;
 end;
 
+function TPasProcedure.IsAssembler: Boolean;
+begin
+  Result:=pmAssembler in FModifiers;
+end;
+
+function TPasProcedure.IsAsync: Boolean;
+begin
+  Result:=pmAsync in FModifiers;
+end;
+
 function TPasProcedure.GetProcTypeEnum: TProcType;
 begin
   Result:=ptProcedure;

packages/fcl-passrc/src/pparser.pp

@@ -1357,13 +1357,15 @@ begin
       case TPasClassType(Parent).ObjKind of
       okInterface,okDispInterface:
         if not (PM in [pmOverload, pmMessage,
-                        pmDispId,pmNoReturn,pmFar,pmFinal]) then exit(false);
+                       pmDispId,pmNoReturn,pmFar,pmFinal]) then exit(false);
       end;
       exit;
       end
     else if Parent is TPasRecordType then
       begin
-      if not (PM in [pmOverload,
+      if PM=pmAsync then
+        exit(po_AsyncProcs in Options)
+      else if not (PM in [pmOverload,
                      pmInline, pmAssembler,
                      pmExternal,
                      pmNoReturn, pmFar, pmFinal]) then exit(false);
@@ -1378,7 +1380,12 @@ function TPasParser.TokenIsAnonymousProcedureModifier(Parent: TPasElement;
 begin
   Result:=IsProcModifier(S,PM);
   if not Result then exit;
-  Result:=PM in [pmAssembler];
+  case PM of
+  pmAssembler: Result:=true;
+  pmAsync: Result:=po_AsyncProcs in Options;
+  else
+    Result:=false;
+  end;
   if Parent=nil then ;
 end;
 

packages/fcl-passrc/src/pscanner.pp

@@ -666,7 +666,8 @@ type
     po_StopOnErrorDirective, // error on user $Error, $message error|fatal
     po_ExtConstWithoutExpr,  // allow typed const without expression in external class and with external modifier
     po_StopOnUnitInterface,  // parse only a unit name and stop at interface keyword
-    po_IgnoreUnknownResource // Ignore resources for which no handler is registered.
+    po_IgnoreUnknownResource, // Ignore resources for which no handler is registered.
+    po_AsyncProcs             // allow async procedure modifier
     );
   TPOptions = set of TPOption;
 

packages/fcl-passrc/tests/tcresolver.pas

@@ -432,6 +432,7 @@ type
     Procedure TestNestedForwardProcUnresolved;
     Procedure TestForwardProcFuncMismatch;
     Procedure TestForwardFuncResultMismatch;
+    Procedure TestForwardProcAssemblerMismatch;
     Procedure TestUnitIntfProc;
     Procedure TestUnitIntfProcUnresolved;
     Procedure TestUnitIntfMismatchArgName;
@@ -7111,6 +7112,17 @@ begin
     nResultTypeMismatchExpectedButFound);
 end;
 
+procedure TTestResolver.TestForwardProcAssemblerMismatch;
+begin
+  StartProgram(false);
+  Add('procedure Run; assembler; forward;');
+  Add('procedure Run;');
+  Add('begin');
+  Add('end;');
+  Add('begin');
+  CheckParserException('Expected "asm"',nParserExpectTokenError);
+end;
+
 procedure TTestResolver.TestUnitIntfProc;
 begin
   StartUnit(false);