paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-01 01:30:35 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Fix parsing of class local consts

Browse Source 
git-svn-id: trunk@22152 -
This commit is contained in:
michael 2012-08-20 22:28:25 +00:00
parent 74624a0c37
commit d13a6e2ca4
2 changed files with 110 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
packages/fcl-passrc/src/pparser.pp
View File

@ -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

84
packages/fcl-passrc/tests/tcclasstype.pas
View File

@ -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);