fcl-passrc: parse and resolve attributes of method arguments

packages/fcl-passrc/src/pasresolver.pp

@@ -9017,6 +9017,7 @@ end;
 
 procedure TPasResolver.FinishAttributes(El: TPasAttributes);
 var
+  IsArg: boolean;
   i, j: Integer;
   NameExpr, Expr: TPasExpr;
   Bin: TBinaryExpr;
@@ -9033,12 +9034,20 @@ var
   DotScope: TPasDotBaseScope;
   Params: TPasExprArray;
 begin
+  IsArg:=El.Parent is TPasArgument;
   for i:=0 to length(El.Calls)-1 do
     begin
     NameExpr:=El.Calls[i];
     {$IFDEF VerbosePasResolver}
     //writeln('TPasResolver.FinishAttributes El.Calls[',i,']=',GetObjName(NameExpr));
     {$ENDIF}
+    if IsArg and (NameExpr.Kind=pekIdent)
+        and (SameText(TPrimitiveExpr(NameExpr).Value,'ref')) then
+    begin
+      if TPasArgument(El.Parent).Access=argConstRef then
+        continue; // const [ref] arg
+    end;
+
     if NameExpr is TParamsExpr then
       NameExpr:=TParamsExpr(NameExpr).Value;
     DotScope:=nil;

packages/fcl-passrc/src/pastree.pp

@@ -854,6 +854,18 @@ type
 
   TArgumentAccess = (argDefault, argConst, argVar, argOut, argConstRef);
 
+  { TPasAttributes }
+
+  TPasAttributes = class(TPasElement)
+  public
+    procedure FreeChildren(Prepare: boolean); override;
+    procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
+      const Arg: Pointer); override;
+    procedure AddCall(Expr: TPasExpr);
+  public
+    Calls: TPasExprArray;
+  end;
+
   { TPasArgument }
 
   TPasArgument = class(TPasElement)
@@ -866,6 +878,7 @@ type
       const Arg: Pointer); override;
   public
     Access: TArgumentAccess;
+    Attributes: TPasAttributes;
     ArgType: TPasType; // can be nil, when Access<>argDefault
     ValueExpr: TPasExpr; // the default value
     Function Value : TPasTreeString;
@@ -1054,18 +1067,6 @@ type
     Function DefaultValue : TPasTreeString;
   end;
 
-  { TPasAttributes }
-
-  TPasAttributes = class(TPasElement)
-  public
-    procedure FreeChildren(Prepare: boolean); override;
-    procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
-      const Arg: Pointer); override;
-    procedure AddCall(Expr: TPasExpr);
-  public
-    Calls: TPasExprArray;
-  end;
-
   TProcType = (ptProcedure, ptFunction,
                ptOperator, ptClassOperator,
                ptConstructor, ptDestructor,
@@ -3615,7 +3616,8 @@ end;
 
 procedure TPasArgument.FreeChildren(Prepare: boolean);
 begin
-  ArgType:=TPasTypeRef(FreeChild(ArgType,Prepare));
+  Attributes:=TPasAttributes(FreeChild(Attributes,Prepare));
+  ArgType:=TPasType(FreeChild(ArgType,Prepare));
   ValueExpr:=TPasExpr(FreeChild(ValueExpr,Prepare));
   inherited FreeChildren(Prepare);
 end;
@@ -3641,14 +3643,17 @@ begin
     Result:=SafeName
   else
     Result:='';
+  If Full and Assigned(Attributes) and (Attributes.Parent=Self) then
+    Result:=Attributes.GetDeclaration(full)+' '+Result;
 end;
 
 procedure TPasArgument.ForEachCall(const aMethodCall: TOnForEachPasElement;
   const Arg: Pointer);
 begin
+  ForEachChildCall(aMethodCall,Arg,Attributes,true);
   inherited ForEachCall(aMethodCall, Arg);
   ForEachChildCall(aMethodCall,Arg,ArgType,true);
-  ForEachChildCall(aMethodCall,Arg,ValueExpr,false);
+  ForEachChildCall(aMethodCall,Arg,ValueExpr,true);
 end;
 
 function TPasArgument.Value: TPasTreeString;

packages/fcl-passrc/src/pparser.pp

@@ -5215,6 +5215,7 @@ procedure TPasParser.ParseArgList(Parent: TPasElement; Args: TFPList; EndToken:
 
 var
   HasRef: Boolean;
+  Attributes: TPasAttributes;
 
   Function GetParamName : string;
 
@@ -5233,18 +5234,40 @@ var
 
   Procedure ParseAttr(Peek : Boolean);
 
+  var
+    Expr: TPasExpr;
+    Prim: TPrimitiveExpr;
+    i: Integer;
+    AddAttributes: TPasAttributes;
   begin
     HasRef:=False;
-    NextToken;
-    While CurToken=tkIdentifier do
+
+    AddAttributes:=ParseAttributes(Parent,false);
+    if AddAttributes<>nil then
       begin
-      HasRef:=HasRef or CurTokenIsIdentifier('ref');
-      NextToken;
-      // We ignore the attribute value for the moment.
-      if CurToken=tkComma then
-        NextToken;
+      // check for 'ref' attribute
+      for i:=0 to length(AddAttributes.Calls)-1 do
+        begin
+        Expr:=AddAttributes.Calls[i];
+        if (Expr.Kind=pekIdent) and (TPrimitiveExpr(Expr).Value='ref') then
+          HasRef:=true;
+        end;
+      if Attributes=nil then
+        Attributes:=AddAttributes
+      else
+        begin
+        // move attributes to first array
+        for i:=0 to length(AddAttributes.Calls)-1 do
+          begin
+          Expr:=AddAttributes.Calls[i];
+          Attributes.AddCall(Expr);
+          Expr.Parent:=Attributes;
+          end;
+        AddAttributes.Calls:=nil;
+        AddAttributes.Free;
+        end;
       end;
-    CheckToken(tkSquaredBraceClose);
+
     if not Peek then
       NextToken;
   end;
@@ -5276,136 +5299,156 @@ var
 
 begin
   LastHadDefaultValue := false;
-  while True do
-  begin
-    OldArgCount:=Args.Count;
-    Access := argDefault;
-    IsUntyped := False;
-    ArgType := nil;
-    NextToken;
-    // [ref] (const|var|) a : type;
-    HasRef:=False;
-    CheckAttributes(False);
-
-    if CurToken = tkDotDotDot then
-    begin
-      expectToken(endToken);
-      Break;
-    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
-      if  ([msObjfpc, msDelphi, msDelphiUnicode, msOut] * CurrentModeswitches)<>[] then
-        begin
-        Access := ArgOut;
-        Name := ExpectIdentifier
-        end
-      else
-        Name := CurTokenString
-    end else if (CurToken = tkproperty) or (CurToken=tkClass) then
-      begin
-      if ([msDelphi,msDelphiUnicode,msObjfpc]* CurrentModeswitches)<>[] then
-        ParseExcTokenError('identifier')
-      else
-        Name := CurTokenString
-    end else if CurToken = tkIdentifier then
-      Name := CurTokenString
-    else
-      ParseExc(nParserExpectedConstVarID,SParserExpectedConstVarID);
+  try
     while True do
     begin
-      Arg := TPasArgument(CreateElement(TPasArgument, Name, Parent));
-      Arg.Access := Access;
-      Args.Add(Arg);
-      NextToken;
-      if CurToken = tkColon then
-        break
-      else if ((CurToken = tkSemicolon) or (CurToken = tkBraceClose)) and
-        (Access <> argDefault) then
-      begin
-        // found an untyped const or var argument
-        UngetToken;
-        IsUntyped := True;
-        break
-      end
-      else if CurToken <> tkComma then
-        ParseExc(nParserExpectedCommaColon,SParserExpectedCommaColon);
+      // parse modifiers and attributes
+      Access := argDefault;
+      IsUntyped := False;
+      ArgType := nil;
       NextToken;
-      if CurToken = tkIdentifier then
+      // [ref] (const|var|) a : type;
+      HasRef:=False;
+      Attributes:=nil;
+      CheckAttributes(False);
+
+      if CurToken = tkDotDotDot then
+      begin
+        expectToken(endToken);
+        Break;
+      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
+        if ([msObjfpc, msDelphi, msDelphiUnicode, msOut] * CurrentModeswitches)<>[] then
+          begin
+          Access := ArgOut;
+          Name := ExpectIdentifier
+          end
+        else
+          Name := CurTokenString
+      end else if (CurToken = tkproperty) or (CurToken=tkClass) then
+        begin
+        if ([msDelphi,msDelphiUnicode,msObjfpc]* CurrentModeswitches)<>[] then
+          ParseExcTokenError('identifier')
+        else
+          Name := CurTokenString
+      end else if CurToken = tkIdentifier then
         Name := CurTokenString
       else
         ParseExc(nParserExpectedConstVarID,SParserExpectedConstVarID);
-    end;
-    Value:=Nil;
-    if not IsUntyped then
-      begin
-      Arg := TPasArgument(Args[OldArgCount]);
-      ArgType:=Nil;
-      oldForceCaret:=Scanner.SetForceCaret(True);
-      try
-        ArgType := ParseType(Arg,CurSourcePos);
+
+      // parse names
+      OldArgCount:=Args.Count;
+      while True do
+        begin
+        Arg := TPasArgument(CreateElement(TPasArgument, Name, Parent));
+        Arg.Access := Access;
+        Args.Add(Arg);
         NextToken;
-        if CurToken = tkEqual then
+        if CurToken = tkColon then
+          break
+        else if ((CurToken = tkSemicolon) or (CurToken = tkBraceClose)) and
+          (Access <> argDefault) then
           begin
-          if (Args.Count>OldArgCount+1) then
-            begin
-            ArgType:=nil;
-            ParseExc(nParserOnlyOneArgumentCanHaveDefault,SParserOnlyOneArgumentCanHaveDefault);
-            end;
-          if Parent is TPasProperty then
-            ParseExc(nParserPropertyArgumentsCanNotHaveDefaultValues,
-              SParserPropertyArgumentsCanNotHaveDefaultValues);
-          NextToken;
-          Value := DoParseExpression(Arg,Nil);
-          // After this, we're on ), which must be unget.
-          LastHadDefaultValue:=true;
+          // found an untyped const or var argument
+          UngetToken;
+          IsUntyped := True;
+          break
           end
-        else if LastHadDefaultValue then
-          ParseExc(nParserDefaultParameterRequiredFor,
-            SParserDefaultParameterRequiredFor,[TPasArgument(Args[OldArgCount]).Name]);
-        UngetToken;
-      finally
-        Scanner.SetForceCaret(oldForceCaret);
-      end;
-      end;
+        else if CurToken <> tkComma then
+          ParseExc(nParserExpectedCommaColon,SParserExpectedCommaColon);
+        NextToken;
+        if CurToken = tkIdentifier then
+          Name := CurTokenString
+        else
+          ParseExc(nParserExpectedConstVarID,SParserExpectedConstVarID);
+        end;
 
-    for i := OldArgCount to Args.Count - 1 do
-    begin
-      Arg := TPasArgument(Args[i]);
-      Arg.ArgType := ArgType;
-      Arg.ValueExpr := Value;
-      Value:=Nil; // Only the first gets a value. OK, since Var A,B : Integer = 1 is not allowed.
-    end;
+      // parse type and default value
+      Value:=Nil;
+      if not IsUntyped then
+        begin
+        Arg := TPasArgument(Args[OldArgCount]);
+        ArgType:=Nil;
+        oldForceCaret:=Scanner.SetForceCaret(True);
+        try
+          ArgType := ParseType(Arg,CurSourcePos);
+          NextToken;
+          if CurToken = tkEqual then
+            begin
+            if (Args.Count>OldArgCount+1) then
+              begin
+              ArgType:=nil;
+              ParseExc(nParserOnlyOneArgumentCanHaveDefault,SParserOnlyOneArgumentCanHaveDefault);
+              end;
+            if Parent is TPasProperty then
+              ParseExc(nParserPropertyArgumentsCanNotHaveDefaultValues,
+                SParserPropertyArgumentsCanNotHaveDefaultValues);
+            NextToken;
+            Value := DoParseExpression(Arg,Nil);
+            // After this, we're on ), which must be unget.
+            LastHadDefaultValue:=true;
+            end
+          else if LastHadDefaultValue then
+            ParseExc(nParserDefaultParameterRequiredFor,
+              SParserDefaultParameterRequiredFor,[TPasArgument(Args[OldArgCount]).Name]);
+          UngetToken;
+        finally
+          Scanner.SetForceCaret(oldForceCaret);
+        end;
+        end;
 
-    for i := OldArgCount to Args.Count - 1 do
-      Engine.FinishScope(stDeclaration,TPasArgument(Args[i]));
+      for i := OldArgCount to Args.Count - 1 do
+        begin
+        Arg := TPasArgument(Args[i]);
+        if Attributes<>nil then
+          begin
+          Arg.Attributes := Attributes;
+          if (i=OldArgCount) then
+            begin
+            Attributes.Parent := Arg;
+            Engine.FinishScope(stDeclaration,Attributes);
+            end;
+          end;
+        Arg.ArgType := ArgType;
+        Arg.ValueExpr := Value;
+        Value:=Nil; // Only the first gets a value. OK, since Var A,B : Integer = 1 is not allowed.
+        end;
+      Attributes:=nil;
 
-    NextToken;
-    if (CurToken = tkIdentifier) and (LowerCase(CurTokenString) = 'location') then
-      begin
+      for i := OldArgCount to Args.Count - 1 do
+        Engine.FinishScope(stDeclaration,TPasArgument(Args[i]));
+
+      NextToken;
+      if (CurToken = tkIdentifier) and (LowerCase(CurTokenString) = 'location') then
+        begin
         NextToken; // remove 'location'
         NextToken; // remove register
-      end;
-    if CurToken = EndToken then
-      break;
-    CheckToken(tkSemicolon);
+        end;
+      if CurToken = EndToken then
+        break;
+      CheckToken(tkSemicolon);
+    end;
+  finally
+    Attributes.Free;
   end;
 end;
 

packages/fcl-passrc/tests/tcresolver.pas

@@ -1005,7 +1005,7 @@ type
     Procedure TestAttributes_NonConstParam_Fail;
     Procedure TestAttributes_UnknownAttrWarning;
     Procedure TestAttributes_Members;
-    Procedure TestAttributes_MethodParams; // todo
+    Procedure TestAttributes_MethodParams;
 
     // library
     Procedure TestLibrary_Empty;
@@ -19274,8 +19274,6 @@ end;
 
 procedure TTestResolver.TestAttributes_MethodParams;
 begin
-  exit;
-
   StartProgram(false);
   Add([
   '{$modeswitch prefixedattributes}',
@@ -19287,6 +19285,7 @@ begin
   '  end;',
   '  TMyClass = class',
   '    procedure Fly([{#attr__custom__create__size}TCustom]Size: word);',
+  '    procedure Eat(const [ref] Portion: word);',
   '  end;',
   'constructor TObject.Create;',
   'begin',
@@ -19294,10 +19293,14 @@ begin
   'procedure TMyClass.Fly(Size: word);',
   'begin',
   'end;',
+  'procedure TMyClass.Eat(const [ref] Portion: word);',
+  'begin',
+  'end;',
   'begin',
   '']);
   ParseProgram;
   CheckAttributeMarkers;
+  CheckResolverUnexpectedHints;
 end;
 
 procedure TTestResolver.TestLibrary_Empty;