paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 21:29:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: resolver: option to allow class property with non static getter/setter

Browse Source 
git-svn-id: trunk@41255 -
This commit is contained in:
Mattias Gaertner 2019-02-08 13:07:02 +00:00
parent 6ec527df23
commit 67dd6b5bf3
2 changed files with 119 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
packages/fcl-passrc/src/pasresolver.pp
View File

@ -1295,7 +1295,7 @@ type
TPasResolverOption = (
proFixCaseOfOverrides, // fix Name of overriding proc/property to the overriden proc/property
proClassPropertyNonStatic, // class property accessors are non static
proClassPropertyNonStatic, // class property accessors can be non static
proPropertyAsVarParam, // allows to pass a property as a var/out argument
proClassOfIs, // class-of supports is and as operator
proExtClassInstanceNoTypeMembers, // class members of external class cannot be accessed by instance
@ -5942,14 +5942,13 @@ begin
RaiseMsg(20181218195552,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'abstract'],Proc);
if Proc.IsForward then
RaiseMsg(20181218195514,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'forward'],Proc);
if Proc.IsStatic then
if (Proc.ClassType<>TPasClassProcedure) and (Proc.ClassType<>TPasClassFunction) then
RaiseMsg(20190206150922,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'static'],Proc);
if IsClassMethod(Proc) then
begin
if not Proc.IsStatic then
RaiseMsg(20190106121503,nClassMethodsMustBeStaticInX,sClassMethodsMustBeStaticInX,['records'],Proc);
end;
end
else if Proc.IsStatic then
RaiseMsg(20190206150922,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'static'],Proc);
end
else
begin
@ -6476,12 +6475,15 @@ var
end;
end;
function ExpectedClassAccessorStatic: boolean;
function CheckClassAccessorStatic(ProcIsStatic: boolean): boolean;
begin
if (ClassScope<>nil) and (proClassPropertyNonStatic in Options) then
Result:=false
if ClassScope=nil then
// record: class getter/setter must be static
Result:=ProcIsStatic=true
else if proClassPropertyNonStatic in Options then
Result:=true // both allowed
else
Result:=true;
Result:=ProcIsStatic=true;
end;
procedure CheckIndexArg(ArgNo: integer; const IndexResolved: TPasResolverResult;
@ -6893,7 +6895,7 @@ begin
begin
if Proc.ClassType<>TPasClassFunction then
RaiseXExpectedButYFound(20170216151834,'class function',GetElementTypeName(Proc),PropEl.ReadAccessor);
if Proc.IsStatic<>ExpectedClassAccessorStatic then
if not CheckClassAccessorStatic(Proc.IsStatic) then
if Proc.IsStatic then
RaiseMsg(20170216151837,nClassPropertyAccessorMustNotBeStatic,sClassPropertyAccessorMustNotBeStatic,[],PropEl.ReadAccessor)
else
@ -6948,7 +6950,7 @@ begin
begin
if Proc.ClassType<>TPasClassProcedure then
RaiseXExpectedButYFound(20170216151903,'class procedure',GetElementTypeName(Proc),PropEl.WriteAccessor);
if Proc.IsStatic<>ExpectedClassAccessorStatic then
if not CheckClassAccessorStatic(Proc.IsStatic) then
if Proc.IsStatic then
RaiseMsg(20170216151905,nClassPropertyAccessorMustNotBeStatic,sClassPropertyAccessorMustNotBeStatic,[],PropEl.WriteAccessor)
else

108
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -585,6 +585,7 @@ type
Procedure TestClass_FuncReturningObjectMember;
Procedure TestClass_StaticWithoutClassFail;
Procedure TestClass_SelfInStaticFail;
Procedure TestClass_SelfDotInStaticFail;
Procedure TestClass_PrivateProtectedInSameUnit;
Procedure TestClass_PrivateInMainBeginFail;
Procedure TestClass_PrivateInDescendantFail;
@ -692,7 +693,11 @@ type
Procedure TestPropertyArgs2;
Procedure TestPropertyArgsWithDefaultsFail;
Procedure TestPropertyArgs_StringConstDefault;
Procedure TestProperty_Index;
Procedure TestClassProperty;
Procedure TestClassPropertyNonStaticFail;
Procedure TestClassPropertyNonStaticAllow;
//Procedure TestClassPropertyStaticMismatchFail;
Procedure TestArrayProperty;
Procedure TestProperty_WrongTypeAsIndexFail;
Procedure TestProperty_Option_ClassPropertyNonStatic;
Procedure TestDefaultProperty;
@ -10038,6 +10043,23 @@ begin
CheckResolverException('identifier not found "Self"',nIdentifierNotFound);
end;
procedure TTestResolver.TestClass_SelfDotInStaticFail;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' class var FLeft: word;');
Add(' class function DoIt: word; static;');
Add(' class property Left: word read FLeft;');
Add(' end;');
Add('class function TObject.DoIt: word;');
Add('begin');
Add(' Result:=Self.Left;');
Add('end;');
Add('begin');
CheckResolverException('identifier not found "Self"',nIdentifierNotFound);
end;
procedure TTestResolver.TestClass_PrivateProtectedInSameUnit;
begin
StartProgram(false);
@ -12175,7 +12197,89 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestProperty_Index;
procedure TTestResolver.TestClassProperty;
begin
StartProgram(false);
Add([
'type',
' TObject = class',
' class function GetStatic: word; static;',
' class procedure SetStatic(Value: word); static;',
' class property StaticP: word read GetStatic write SetStatic;',
' end;',
'class function TObject.GetStatic: word;',
'begin',
' StaticP:=StaticP;',
'end;',
'class procedure TObject.SetStatic(Value: word);',
'begin',
'end;',
'begin',
'']);
ParseProgram;
end;
procedure TTestResolver.TestClassPropertyNonStaticFail;
begin
StartProgram(false);
Add([
'type',
' TObject = class',
' class function GetNonStatic: word;',
' class property NonStatic: word read GetNonStatic;',
' end;',
'class function TObject.GetNonStatic: word;',
'begin',
'end;',
'begin',
'']);
CheckResolverException(sClassPropertyAccessorMustBeStatic,nClassPropertyAccessorMustBeStatic);
end;
procedure TTestResolver.TestClassPropertyNonStaticAllow;
begin
ResolverEngine.Options:=ResolverEngine.Options+[proClassPropertyNonStatic];
StartProgram(false);
Add([
'type',
' TObject = class',
' class function GetStatic: word; static;',
' class procedure SetStatic(Value: word); static;',
' class property StaticP: word read GetStatic write SetStatic;',
' class function GetNonStatic: word;',
' class procedure SetNonStatic(Value: word);',
' class property NonStatic: word read GetNonStatic write SetNonStatic;',
' end;',
' TClass = class of TObject;',
'class function TObject.GetStatic: word;',
'begin',
' StaticP:=StaticP;',
' NonStatic:=NonStatic;',
'end;',
'class procedure TObject.SetStatic(Value: word);',
'begin',
'end;',
'class function TObject.GetNonStatic: word;',
'begin',
' StaticP:=StaticP;',
' NonStatic:=NonStatic;',
'end;',
'class procedure TObject.SetNonStatic(Value: word);',
'begin',
'end;',
'var',
' c: TClass;',
' o: TObject;',
'begin',
' c.STaticP:=c.StaticP;',
' o.STaticP:=o.StaticP;',
' c.NonStatic:=c.NonStatic;',
' o.NonStatic:=o.NonStatic;',
'']);
ParseProgram;
end;
procedure TTestResolver.TestArrayProperty;
begin
StartProgram(false);
Add('type');