* Allow Delphi-style const [ref]

packages/fcl-passrc/src/pparser.pp

@@ -5070,6 +5070,10 @@ end;
 // Starts after the opening bracket token
 procedure TPasParser.ParseArgList(Parent: TPasElement; Args: TFPList; EndToken: TToken);
 
+
+var
+  HasRef: Boolean;
+
   Function GetParamName : string;
 
   begin
@@ -5084,6 +5088,41 @@ procedure TPasParser.ParseArgList(Parent: TPasElement; Args: TFPList; EndToken:
         ParseExcTokenError('identifier')
       end;
   end;
+
+  Procedure ParseAttr(Peek : Boolean);
+
+  begin
+    HasRef:=False;
+    NextToken;
+    While CurToken=tkIdentifier do
+      begin
+      HasRef:=HasRef or CurTokenIsIdentifier('ref');
+      NextToken;
+      // We ignore the attribute value for the moment.
+      if CurToken=tkComma then
+        NextToken;
+      end;
+    CheckToken(tkSquaredBraceClose);
+    if not Peek then
+      NextToken;
+  end;
+
+  Function CheckAttributes(peek: boolean) : Boolean;
+
+  begin
+    if Peek then
+      NextToken;
+    Result:=CurToken = tkSquaredBraceOpen;
+    if Result then
+      begin
+      if not (msPrefixedAttributes in CurrentModeswitches) then
+        ParseExc(nParserExpectedConstVarID,SParserExpectedConstVarID);
+      ParseAttr(Peek);
+      end
+    else if Peek then
+      UnGettoken;
+  end;
+
 var
   OldForceCaret,IsUntyped, LastHadDefaultValue: Boolean;
   Name : String;
@@ -5092,6 +5131,8 @@ var
   Arg: TPasArgument;
   Access: TArgumentAccess;
   ArgType: TPasType;
+  HasAttr : Boolean;
+
 begin
   LastHadDefaultValue := false;
   while True do
@@ -5101,6 +5142,10 @@ begin
     IsUntyped := False;
     ArgType := nil;
     NextToken;
+    // [ref] (const|var|) a : type;
+    HasRef:=False;
+    HasAttr:=CheckAttributes(False);
+
     if CurToken = tkDotDotDot then
     begin
       expectToken(endToken);
@@ -5108,14 +5153,21 @@ begin
     end else  if CurToken = tkConst then
     begin
       Access := argConst;
+      // (const|var|) [ref]  a : type;
+      CheckAttributes(True);
+      if HasRef then
+        Access := argConstRef;
       Name := GetParamName;
     end else if CurToken = tkConstRef then
     begin
       Access := argConstref;
+      CheckAttributes(True);
       Name := getParamName;
     end else if CurToken = tkVar then
     begin
       Access := ArgVar;
+      // (const|var|) [ref]  a : type;
+      CheckAttributes(True);
       Name:=GetParamName;
     end else if (CurToken = tkIdentifier) and (UpperCase(CurTokenString) = 'OUT') then
     begin

packages/fcl-passrc/tests/tcclasstype.pas

@@ -82,6 +82,8 @@ type
     procedure TestOneSpecializedClassInterface;
     Procedure TestOneField;
     Procedure TestOneFieldComment;
+    procedure TestOneFieldWithAttribute;
+    procedure TestOneFieldVarWithAttribute;
     Procedure TestOneClassOfField;
     procedure TestOneFieldStatic;
     Procedure TestOneHelperField;
@@ -592,7 +594,7 @@ begin
   ParseClass;
 end;
 
-Procedure TTestClassType.TestForwardExternalObjCClass;
+procedure TTestClassType.TestForwardExternalObjCClass;
 begin
   FStarted:=True;
   FEnded:=True;
@@ -715,6 +717,26 @@ begin
   AssertVisibility;
 end;
 
+procedure TTestClassType.TestOneFieldWithAttribute;
+begin
+  Parser.CurrentModeswitches:=Parser.CurrentModeswitches+[msPrefixedAttributes];
+  AddMember('[volatile] a : integer');
+  ParseClass;
+  AssertEquals('Have 2 members',2,TheClass.Members.Count);
+  AssertMemberName('a',Members[1]);
+  AssertVisibility;
+end;
+
+procedure TTestClassType.TestOneFieldVarWithAttribute;
+begin
+  Parser.CurrentModeswitches:=Parser.CurrentModeswitches+[msPrefixedAttributes];
+  AddMember('var [volatile] a : integer');
+  ParseClass;
+  AssertEquals('Have 2 members',2,TheClass.Members.Count);
+  AssertMemberName('a',Members[1]);
+end;
+
+
 procedure TTestClassType.TestOneFieldStatic;
 begin
   AddMember('a : integer; static');
@@ -2323,7 +2345,7 @@ begin
   AssertVisibility;
 end;
 
-Procedure TTestClassType.TestExternalClassFunctionFinal;
+procedure TTestClassType.TestExternalClassFunctionFinal;
 
 begin
   Parser.CurrentModeswitches:=[msObjfpc,msexternalClass];

packages/fcl-passrc/tests/tcprocfunc.pas

@@ -69,6 +69,8 @@ type
     Procedure TestFunctionOneOutArg;
     procedure TestProcedureOneConstRefArg;
     Procedure TestFunctionOneConstRefArg;
+    procedure TestFunctionOneConstRefAttributeArg;
+    procedure TestFunctionOneConstRefAttributeArgReversed;
     procedure TestProcedureTwoArgs;
     Procedure TestFunctionTwoArgs;
     procedure TestProcedureTwoArgsSeparate;
@@ -515,7 +517,7 @@ begin
   AssertArg(ProcType,0,'B',argDefault,'^Integer','');
 end;
 
-procedure TTestProcedureFunction.TestFunctionPointerResult;
+procedure TTestProcedureFunction.TestFUnctionPointerResult;
 begin
   ParseFunction('()','^LongInt');
   AssertFunc([],[],ccDefault,0);
@@ -556,6 +558,24 @@ begin
   AssertArg(FuncType,0,'B',argConst,'Integer','');
 end;
 
+
+procedure TTestProcedureFunction.TestFunctionOneConstRefAttributeArg;
+begin
+  Parser.CurrentModeswitches:=Parser.CurrentModeswitches+[msPrefixedAttributes];
+  ParseFunction('([ref] Const B : Integer)');
+  AssertFunc([],[],ccDefault,1);
+  AssertArg(FuncType,0,'B',argConstRef,'Integer','');
+end;
+
+procedure TTestProcedureFunction.TestFunctionOneConstRefAttributeArgReversed;
+begin
+  Parser.CurrentModeswitches:=Parser.CurrentModeswitches+[msPrefixedAttributes];
+  ParseFunction('(Const [ref] B : Integer)');
+  AssertFunc([],[],ccDefault,1);
+  AssertArg(FuncType,0,'B',argConstRef,'Integer','');
+end;
+
+
 procedure TTestProcedureFunction.TestProcedureOneOutArg;
 begin
   Parser.CurrentModeswitches:=[msObjfpc];
@@ -1491,7 +1511,7 @@ end;
 
 
 
-Procedure TTestProcedureFunction.TestFunctionSyscallSingleNumber;
+procedure TTestProcedureFunction.TestFunctionSyscallSingleNumber;
 begin
   // function Something : Someresult; syscall 12
   AddDeclaration('function A : Integer; syscall 12');
@@ -1500,7 +1520,7 @@ begin
 end;
 
 
-Procedure TTestProcedureFunction.TestFunctionSyscallDoubleNumber;
+procedure TTestProcedureFunction.TestFunctionSyscallDoubleNumber;
 
 begin
   // function Something : Someresult; syscall 12 13
@@ -1510,7 +1530,7 @@ begin
 end;
 
 
-Procedure TTestProcedureFunction.TestFunctionSysCallSysTrapIdentifier;
+procedure TTestProcedureFunction.TestFunctionSysCallSysTrapIdentifier;
 
 begin
   // function Something : Someresult; syscall systrapNNN

packages/fcl-passrc/tests/tcvarparser.pas

@@ -64,6 +64,7 @@ Type
     Procedure TestVarPublicName;
     Procedure TestVarDeprecatedExternalName;
     Procedure TestVarHintPriorToInit;
+    Procedure TestVarAttribute;
     Procedure TestErrorRecovery;
   end;
 
@@ -452,6 +453,22 @@ begin
   AssertEquals('Correct initialization value',False, E.Value);
 end;
 
+procedure TTestVarParser.TestVarAttribute;
+var
+  V : TPasVariable;
+begin
+
+  add('{$mode delphi}');
+  Add('Var');
+  Add('  [xyz] A : integer;');
+  ParseDeclarations;
+  AssertEquals('One variable definition',1,Declarations.Variables.Count);
+  AssertEquals('First declaration is type definition.',TPasVariable,TObject(Declarations.Variables[0]).ClassType);
+  V:=TPasVariable(Declarations.Variables[0]);
+  AssertEquals('First declaration has correct name.','A',V.Name);
+
+end;
+
 procedure TTestVarParser.TestErrorRecovery;
 
 begin

packages/fcl-passrc/tests/testpassrc.lpi

@@ -27,13 +27,13 @@
     </PublishOptions>
     <RunParams>
       <local>
-        <CommandLineParams Value="--suite=TTestScanner.TestDelphiMultiLineTrailingGarbage2"/>
+        <CommandLineParams Value="--suite=TTestProcedureFunction.TestFunctionOneConstRefAttributeArg"/>
       </local>
       <FormatVersion Value="2"/>
       <Modes Count="1">
         <Mode0 Name="default">
           <local>
-            <CommandLineParams Value="--suite=TTestScanner.TestDelphiMultiLineTrailingGarbage2"/>
+            <CommandLineParams Value="--suite=TTestProcedureFunction.TestFunctionOneConstRefAttributeArg"/>
           </local>
         </Mode0>
       </Modes>