* Support for functions in records

git-svn-id: trunk@29553 -

packages/fcl-passrc/src/pparser.pp

@@ -63,7 +63,7 @@ resourcestring
   SParserNoConstructorAllowed = 'Constructors or Destructors are not allowed in Interfaces or Record helpers';
   SParserNoFieldsAllowed = 'Fields are not allowed in Interfaces';
   SParserInvalidRecordVisibility = 'Records can only have public and (strict) private as visibility specifiers';
-
+  SErrRecordMethodsNotAllowed = 'Record methods not allowed at this location.';
 type
   TPasParserLogHandler = Procedure (Sender : TObject; Const Msg : String) of object;
   TPParserLogEvent = (pleInterface,pleImplementation);
@@ -150,7 +150,7 @@ type
     Procedure DoLog(Const Msg : String; SkipSourceInfo : Boolean = False);overload;
     Procedure DoLog(Const Fmt : String; Args : Array of const;SkipSourceInfo : Boolean = False);overload;
     function GetProcTypeFromToken(tk: TToken; IsClass: Boolean=False ): TProcType;
-    procedure ParseRecordFieldList(ARec: TPasRecordType; AEndToken: TToken);
+    procedure ParseRecordFieldList(ARec: TPasRecordType; AEndToken: TToken; AllowMethods : Boolean);
     procedure ParseRecordVariantParts(ARec: TPasRecordType; AEndToken: TToken);
     function GetProcedureClass(ProcType : TProcType): TPTreeElement;
     procedure ParseClassFields(AType: TPasClassType; const AVisibility: TPasMemberVisibility; IsClassField : Boolean);
@@ -3587,7 +3587,7 @@ begin
     NextToken;
     M:=TPasRecordType(CreateElement(TPasRecordType,'',V));
     V.Members:=M;
-    ParseRecordFieldList(M,tkBraceClose);
+    ParseRecordFieldList(M,tkBraceClose,False);
     // Current token is closing ), so we eat that
     NextToken;
     // If there is a semicolon, we eat that too.
@@ -3612,16 +3612,31 @@ begin
 end;
 
 // Starts on first token after Record or (. Ends on AEndToken
-Procedure TPasParser.ParseRecordFieldList(ARec : TPasRecordType; AEndToken : TToken);
+Procedure TPasParser.ParseRecordFieldList(ARec : TPasRecordType; AEndToken : TToken; AllowMethods : Boolean);
 
 Var
   VN : String;
   v : TPasmemberVisibility;
+  Proc: TPasProcedure;
+  ProcType: TProcType;
 
 begin
+  v:=visPublic;
   while CurToken<>AEndToken do
     begin
     Case CurToken of
+      tkProcedure,
+      tkFunction :
+        begin
+        if Not AllowMethods then
+          ParseExc(SErrRecordMethodsNotAllowed);
+        ProcType:=GetProcTypeFromtoken(CurToken,False);
+        Proc:=ParseProcedureOrFunctionDecl(ARec,ProcType,v);
+        if Proc.Parent is TPasOverloadedProc then
+          TPasOverloadedProc(Proc.Parent).Overloads.Add(Proc)
+        else
+          ARec.Members.Add(Proc);
+        end;
       tkIdentifier :
         begin
         v:=visDefault;
@@ -3669,7 +3684,7 @@ begin
     try
       Result.PackMode:=PackMode;
       NextToken;
-      ParseRecordFieldList(Result,tkEnd);
+      ParseRecordFieldList(Result,tkEnd,true);
     except
       FreeAndNil(Result);
       Raise;

packages/fcl-passrc/tests/tctypeparser.pas

@@ -160,12 +160,14 @@ type
     procedure AssertVariantSelector(AName, AType: string);
     procedure AssertField1(Hints: TPasMemberHints);
     procedure AssertField2(Hints: TPasMemberHints);
+    procedure AssertMethod2(Hints: TPasMemberHints);
     procedure AssertVariant1(Hints: TPasMemberHints);
     procedure AssertVariant1(Hints: TPasMemberHints; VariantLabels : Array of string);
     procedure AssertVariant2(Hints: TPasMemberHints);
     procedure AssertVariant2(Hints: TPasMemberHints; VariantLabels : Array of string);
     procedure AssertOneIntegerField(Hints: TPasMemberHints);
     procedure AssertTwoIntegerFields(Hints1, Hints2: TPasMemberHints);
+    procedure AssertIntegerFieldAndMethod(Hints1, Hints2: TPasMemberHints);
     procedure AssertRecordField(AIndex: Integer;Hints: TPasMemberHints);
     procedure AssertRecordVariant(AIndex: Integer;Hints: TPasMemberHints; VariantLabels : Array of string);
     Procedure AssertRecordVariantVariant(AIndex: Integer;Const AFieldName,ATypeName: string;Hints: TPasMemberHints; VariantLabels : Array of string);
@@ -228,6 +230,8 @@ type
     Procedure TestTwoDeprecatedFieldsCombined;
     Procedure TestTwoDeprecatedFieldsCombinedDeprecated;
     Procedure TestTwoDeprecatedFieldsCombinedPlatform;
+    Procedure TestFieldAndMethod;
+    Procedure TestFieldAnd2Methods;
     Procedure TestNested;
     Procedure TestNestedDeprecated;
     Procedure TestNestedPlatform;
@@ -1434,6 +1438,18 @@ begin
   AssertTrue('Field 2 hints match',Field2.Hints=Hints)
 end;
 
+procedure TTestRecordTypeParser.AssertMethod2(Hints: TPasMemberHints);
+
+Var
+  P : TPasProcedure;
+
+begin
+  AssertEquals('Member 2 type',TPasProcedure,TObject(TheRecord.Members[1]).ClassType);
+  P:=TPasProcedure(TheRecord.Members[1]);
+  AssertEquals('Method name','dosomething2',P.Name);
+  AssertTrue('Method hints match',P.Hints=Hints)
+end;
+
 procedure TTestRecordTypeParser.AssertOneIntegerField(Hints : TPasMemberHints);
 
 begin
@@ -1449,6 +1465,14 @@ begin
   AssertField2(Hints2);
 end;
 
+procedure TTestRecordTypeParser.AssertIntegerFieldAndMethod(Hints1,
+  Hints2: TPasMemberHints);
+begin
+  AssertEquals('Two members',2,TheRecord.Members.Count);
+  AssertField1(Hints1);
+  AssertMethod2(Hints2);
+end;
+
 procedure TTestRecordTypeParser.AssertRecordField(AIndex: Integer;
   Hints: TPasMemberHints);
 
@@ -1771,6 +1795,29 @@ begin
   AssertTwoIntegerFields([hdeprecated],[hdeprecated]);
 end;
 
+procedure TTestRecordTypeParser.TestFieldAndMethod;
+begin
+  TestFields(['x : integer;','procedure dosomething2;'],'',False);
+  AssertIntegerFieldAndMethod([],[]);
+end;
+
+procedure TTestRecordTypeParser.TestFieldAnd2Methods;
+Var
+  P : TPasFunction;
+
+begin
+  TestFields(['x : integer;','procedure dosomething2;','function dosomething3 : Integer;'],'',False);
+  AssertEquals('Member count',3,TheRecord.Members.Count);
+  AssertField1([]);
+  AssertMethod2([]);
+  AssertEquals('Member 3 type',TPasFunction,TObject(TheRecord.Members[2]).ClassType);
+  P:=TPasFunction(TheRecord.Members[2]);
+  AssertEquals('Method 2 name','dosomething3',P.Name);
+  AssertTrue('Method 2 hints match',[]=P.Hints);
+  // Standard type
+  AssertEquals('Method 2 result type','Integer', P.FuncType.ResultEl.ResultType.Name);
+end;
+
 procedure TTestRecordTypeParser.TestNested;
 begin
   TestFields(['x : integer;','y : record','  z : integer;','end'],'',False);

packages/fcl-passrc/tests/testpassrc.lpi

@@ -34,13 +34,10 @@
         <LaunchingApplication Use="True"/>
       </local>
     </RunParams>
-    <RequiredPackages Count="2">
+    <RequiredPackages Count="1">
       <Item1>
-        <PackageName Value="FPCUnitConsoleRunner"/>
-      </Item1>
-      <Item2>
         <PackageName Value="FCL"/>
-      </Item2>
+      </Item1>
     </RequiredPackages>
     <Units Count="12">
       <Unit0>
@@ -109,6 +106,7 @@
     <Version Value="11"/>
     <SearchPaths>
       <IncludeFiles Value="$(ProjOutDir)"/>
+      <OtherUnitFiles Value="../src"/>
     </SearchPaths>
     <Other>
       <CompilerMessages>