diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index ed7c908175..019dc76c77 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/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; diff --git a/packages/fcl-passrc/tests/tctypeparser.pas b/packages/fcl-passrc/tests/tctypeparser.pas index 4cbeddfe03..e4ed8bbc9c 100644 --- a/packages/fcl-passrc/tests/tctypeparser.pas +++ b/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); diff --git a/packages/fcl-passrc/tests/testpassrc.lpi b/packages/fcl-passrc/tests/testpassrc.lpi index 5ecd63b6ce..3686d7cc87 100644 --- a/packages/fcl-passrc/tests/testpassrc.lpi +++ b/packages/fcl-passrc/tests/testpassrc.lpi @@ -34,13 +34,10 @@ - + - - - - + @@ -109,6 +106,7 @@ +