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

fcl-passrc: allow static directive repetition in method implementation

Browse Source 
git-svn-id: trunk@45069 -
This commit is contained in:
Mattias Gaertner 2020-04-25 13:54:15 +00:00
parent 687b31575b
commit bb4557c5fe
3 changed files with 32 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
packages/fcl-passrc/src/pasresolveeval.pas
View File

@ -206,6 +206,7 @@ const
nInferredTypeXFromDiffArgsMismatchFromMethodY = 3140;
nParamOfThisTypeCannotHaveDefVal = 3141;
nClassTypesAreNotRelatedXY = 3142;
nDirectiveXNotAllowedHere = 3143;
// using same IDs as FPC
nVirtualMethodXHasLowerVisibility = 3250; // was 3050
@ -359,6 +360,7 @@ resourcestring
sInferredTypeXFromDiffArgsMismatchFromMethodY = 'Inferred type "%s" from different arguments mismatch for method "%s"';
sParamOfThisTypeCannotHaveDefVal = 'Parameters of this type cannot have default values';
sClassTypesAreNotRelatedXY = 'Class types "%s" and "%s" are not related';
sDirectiveXNotAllowedHere = 'Directive "%s" not allowed here';
type
{ TResolveData - base class for data stored in TPasElement.CustomData }

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

@ -5189,7 +5189,7 @@ begin
fpkProc:
// proc hides a non proc
if (Data^.Proc.GetModule=El.GetModule) then
// forbidden within same CurModule
// forbidden within same module
RaiseMsg(20170216151649,nDuplicateIdentifier,sDuplicateIdentifier,
[El.Name,GetElementSourcePosStr(El)],Data^.Proc.ProcType)
else
@ -6930,7 +6930,7 @@ begin
RaiseInvalidProcModifier(20170216151637,Proc,pmOverride,Proc);
if Proc.IsMessage then
RaiseInvalidProcModifier(20170216151638,Proc,pmMessage,Proc);
if Proc.IsStatic then
if Proc.IsStatic and not HasDots then
RaiseInvalidProcTypeModifier(20170216151640,El,ptmStatic,El);
if (not HasDots)
and (Proc.GetProcTypeEnum in [
@ -9205,11 +9205,11 @@ var
DeclName, ImplName: String;
ImplResult, DeclResult: TPasType;
ImplTemplType, DeclTemplType: TPasGenericTemplateType;
NewImplPTMods: TProcTypeModifiers;
ptm: TProcTypeModifier;
begin
if ImplProc.ClassType<>DeclProc.ClassType then
RaiseXExpectedButYFound(20170216151729,DeclProc.TypeName,ImplProc.TypeName,ImplProc);
if ImplProc.CallingConvention<>DeclProc.CallingConvention then
RaiseMsg(20170216151731,nCallingConventionMismatch,sCallingConventionMismatch,[],ImplProc);
DeclArgs:=DeclProc.ProcType.Args;
ImplArgs:=ImplProc.ProcType.Args;
@ -9273,6 +9273,15 @@ begin
RaiseIncompatibleType(20170216151734,nResultTypeMismatchExpectedButFound,
[],DeclResult,ImplResult,ImplProc);
end;
// modifiers
if ImplProc.CallingConvention<>DeclProc.CallingConvention then
RaiseMsg(20170216151731,nCallingConventionMismatch,sCallingConventionMismatch,[],ImplProc);
NewImplPTMods:=ImplProc.ProcType.Modifiers-DeclProc.ProcType.Modifiers;
if NewImplPTMods<>[] then
for ptm in NewImplPTMods do
RaiseMsg(20200425154821,nDirectiveXNotAllowedHere,sDirectiveXNotAllowedHere,
[ProcTypeModifiers[ptm]],ImplProc.ProcType);
end;
procedure TPasResolver.ResolveImplBlock(Block: TPasImplBlock);

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

@ -601,6 +601,7 @@ type
Procedure TestClass_StaticWithoutClassFail;
Procedure TestClass_SelfInStaticFail;
Procedure TestClass_SelfDotInStaticFail;
Procedure TestClass_ProcStaticMismatchFail;
Procedure TestClass_PrivateProtectedInSameUnit;
Procedure TestClass_PrivateInMainBeginFail;
Procedure TestClass_PrivateInDescendantFail;
@ -8596,7 +8597,7 @@ begin
'begin',
' w:=w+1;',
'end;',
'class procedure TRec.Create;',
'class procedure TRec.Create; static;',
'begin',
' w:=w+1;',
'end;',
@ -10513,6 +10514,21 @@ begin
CheckResolverException('identifier not found "Self"',nIdentifierNotFound);
end;
procedure TTestResolver.TestClass_ProcStaticMismatchFail;
begin
StartProgram(false);
Add([
'type',
' TObject = class',
' procedure Run;',
' end;',
'procedure TObject.Run; static;',
'begin',
'end;',
'begin']);
CheckResolverException('Directive "static" not allowed here',nDirectiveXNotAllowedHere);
end;
procedure TTestResolver.TestClass_PrivateProtectedInSameUnit;
begin
StartProgram(false);