From d13a6e2ca465343e524c44bbf89d170d7251d2de Mon Sep 17 00:00:00 2001 From: michael Date: Mon, 20 Aug 2012 22:28:25 +0000 Subject: [PATCH] * Fix parsing of class local consts git-svn-id: trunk@22152 - --- packages/fcl-passrc/src/pparser.pp | 26 +++++++ packages/fcl-passrc/tests/tcclasstype.pas | 84 +++++++++++++++++++++++ 2 files changed, 110 insertions(+) diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index c761d5f916..a7735fcd0a 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -135,6 +135,7 @@ type function GetVariableModifiers(Out VarMods : TVariableModifiers; Out Libname,ExportName : string): string; function GetVariableValueAndLocation(Parent : TPasElement; Out Value : TPasExpr; Out Location: String): Boolean; procedure HandleProcedureModifier(Parent: TPasElement; pm : TProcedureModifier); + procedure ParseClassLocalConsts(AType: TPasClassType; AVisibility: TPasMemberVisibility); procedure ParseClassLocalTypes(AType: TPasClassType; AVisibility: TPasMemberVisibility); procedure ParseVarList(Parent: TPasElement; VarList: TFPList; AVisibility: TPasMemberVisibility; Full: Boolean); protected @@ -1531,6 +1532,7 @@ begin else begin Result:=TPasOverloadedProc.Create(AName, OldMember.Parent); + Result.Visibility:=OldMember.Visibility; Result.Overloads.Add(OldMember); AList[i] := Result; end; @@ -3657,6 +3659,25 @@ begin Until Done; end; +procedure TPasParser.ParseClassLocalConsts(AType: TPasClassType; AVisibility : TPasMemberVisibility); + +Var + C : TPasConst; + Done : Boolean; +begin +// Writeln('Parsing local consts'); + Repeat + C:=ParseConstDecl(AType); + C.Visibility:=AVisibility; + AType.Members.Add(C); +// Writeln(CurtokenString,' ',TokenInfos[Curtoken]); + NextToken; + Done:=Curtoken<>tkIdentifier; + if Done then + UngetToken; + Until Done; +end; + procedure TPasParser.ParseClassMembers(AType: TPasClassType); Var @@ -3672,6 +3693,11 @@ begin ExpectToken(tkIdentifier); ParseClassLocalTypes(AType,CurVisibility); end; + tkConst: + begin + ExpectToken(tkIdentifier); + ParseClassLocalConsts(AType,CurVisibility); + end; tkVar, tkIdentifier: begin diff --git a/packages/fcl-passrc/tests/tcclasstype.pas b/packages/fcl-passrc/tests/tcclasstype.pas index 662f28cd88..4954ec5495 100644 --- a/packages/fcl-passrc/tests/tcclasstype.pas +++ b/packages/fcl-passrc/tests/tcclasstype.pas @@ -19,6 +19,7 @@ type FParent : String; FEnded, FStarted: Boolean; + function GetC(AIndex: Integer): TPasConst; function GetF1: TPasVariable; function GetM(AIndex : Integer): TPasElement; function GetMM(AIndex : Integer): TPasProcedure; @@ -51,6 +52,8 @@ type Property Property2 : TPasProperty Read GetP2; Property Type1 : TPasType Index 0 Read GetT; Property Type2 : TPasType Index 1 Read GetT; + Property Const1 : TPasConst Index 0 Read GetC; + Property Const2 : TPasConst Index 1 Read GetC; published procedure TestEmpty; procedure TestEmptyDeprecated; @@ -85,6 +88,8 @@ type procedure TestMethodReintroduce; procedure TestMethodInline; Procedure TestMethodVisibility; + Procedure TestMethodSVisibility; + Procedure TestMethodOverloadVisibility; Procedure TestMethodHint; Procedure TestMethodVirtualHint; Procedure Test2Methods; @@ -110,6 +115,8 @@ type procedure TestPropertyReadWriteFromRecordField; Procedure TestLocalSimpleType; Procedure TestLocalSimpleTypes; + Procedure TestLocalSimpleConst; + Procedure TestLocalSimpleConsts; end; implementation @@ -170,6 +177,14 @@ begin Result:=TPasVariable(Member1); end; +function TTestClassType.GetC(AIndex: Integer): TPasConst; +begin + AssertNotNull('Have member '+IntToStr(AIndex),Members[AIndex]); + if not (Members[AIndex] is TPasConst) then + Fail('Member '+IntToStr(AIndex)+' is not a const'); + Result:=TPasConst(Members[AIndex]); +end; + procedure TTestClassType.StartClass(AParent: String = 'TObject'; InterfaceList: String = ''); Var @@ -649,6 +664,35 @@ begin AssertEquals('Default calling convention',ccDefault, Method1.ProcType.CallingConvention); end; +procedure TTestClassType.TestMethodSVisibility; +begin + AddMember('Procedure DoSomething(A : Integer)'); + StartVisibility(visPublic); + AddMember('Procedure DoSomethingB(A : Integer)'); + ParseClass; + DefaultMethod; + AssertEquals('First Default visibility',visDefault,Method1.Visibility); + AssertEquals('No modifiers',[],Method1.Modifiers); + AssertEquals('Default calling convention',ccDefault, Method1.ProcType.CallingConvention); + AssertNotNull('Have method 2',Method2); + AssertEquals('Second Default visibility',visPublic,Method2.Visibility); + AssertNotNull('Method proc type',Method2.ProcType); + AssertMemberName('DoSomethingB',Method2); + AssertEquals('1 argument',1,Method2.ProcType.Args.Count) ; + AssertEquals('Argument name','A',TPasVariable(Method2.ProcType.Args[0]).Name); +end; + +procedure TTestClassType.TestMethodOverloadVisibility; +begin + AddMember('Procedure DoSomething(A : Integer)'); + StartVisibility(visPublic); + AddMember('Procedure DoSomething(A : String)'); + ParseClass; + AssertNotNull('Have member 1',Member1); + AssertEquals('Overload',TPasOverloadedProc,Member1.ClassType); + AssertEquals('Default visibility',visDefault,Member1.Visibility); +end; + procedure TTestClassType.TestMethodHint; begin AddMember('Procedure DoSomething(A : Integer) deprecated'); @@ -1078,6 +1122,46 @@ begin AssertEquals('method name','Something', Method3.Name); end; +procedure TTestClassType.TestLocalSimpleConst; +begin + StartVisibility(visPublic); + FDecl.add('Const'); + AddMember(' A = 23'); + AddMember('Procedure Something'); + ParseClass; + AssertEquals('Local const value',TPasConst, Const1.ClassType); + AssertEquals('Visibility is correct',VisPublic, Const1.Visibility); + AssertEquals('Const name','A', Const1.Name); + AssertExpression('Const value',Const1.Expr,pekNUmber,'23'); + AssertSame('Const parent is class',TheClass, Const1.Parent); + AssertNotNull('Member 2 is procedure',Method2); + AssertEquals('method name','Something', Method2.Name); +end; + +procedure TTestClassType.TestLocalSimpleConsts; +begin + StartVisibility(visPublic); + FDecl.add('Const'); + AddMember(' A = 23'); + AddMember(' B = 45'); + AddMember('Procedure Something'); + ParseClass; + // Const A + AssertEquals('Local const value',TPasConst, Const1.ClassType); + AssertEquals('Visibility is correct',VisPublic, Const1.Visibility); + AssertEquals('Const name','A', Const1.Name); + AssertExpression('Const value',Const1.Expr,pekNUmber,'23'); + AssertSame('Type parent is class',TheClass, Const1.Parent); + // Const B + AssertEquals('Local const value',TPasConst, Const2.ClassType); + AssertEquals('Visibility is correct',VisPublic, Const2.Visibility); + AssertEquals('Const name','B', Const2.Name); + AssertExpression('Const value',Const2.Expr,pekNUmber,'45'); + AssertSame('Type parent is class',TheClass, Const2.Parent); + AssertNotNull('Member 3 is procedure',Method3); + AssertEquals('method name','Something', Method3.Name); +end; + initialization RegisterTest(TTestClassType);