mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 04:39:28 +02:00
fcl-passrc: parse class helper class var, resolver: check helper ancestor
git-svn-id: trunk@40881 -
This commit is contained in:
Mattias Gaertner
parent
13793e9354
commit
ccdc0ce767
@ -176,7 +176,8 @@ const
|
||||
nCantAssignValuesToConstVariable = 3110;
|
||||
nIllegalAssignmentToForLoopVar = 3111;
|
||||
nFunctionHidesIdentifier_NonProc = 3112;
|
||||
// Note: use one of the free IDs above
|
||||
nTypeXCannotBeExtendedByATypeHelper = 3113;
|
||||
nDerivedXMustExtendASubClassY = 3114;
|
||||
|
||||
// using same IDs as FPC
|
||||
nVirtualMethodXHasLowerVisibility = 3250; // was 3050
|
||||
@ -300,6 +301,8 @@ resourcestring
|
||||
sMissingFieldsX = 'Missing fields: "%s"';
|
||||
sCantAssignValuesToConstVariable = 'Can''t assign values to const variable';
|
||||
sIllegalAssignmentToForLoopVar = 'Illegal assignment to for-loop variable "%s"';
|
||||
sTypeXCannotBeExtendedByATypeHelper = 'Type "%s" cannot be extended by a type helper';
|
||||
sDerivedXMustExtendASubClassY = 'Derived %s must extend a subclass of "%s" or the class itself';
|
||||
|
||||
type
|
||||
{ TResolveData - base class for data stored in TPasElement.CustomData }
|
||||
|
||||
@ -50,6 +50,15 @@ Works:
|
||||
- const param makes children const too
|
||||
- const TRecordValues
|
||||
- function default(record type): record
|
||||
- advanced records:
|
||||
- $modeswitch AdvancedRecords
|
||||
- visibility public, private, strict private
|
||||
- sub type
|
||||
- const, var, class var
|
||||
- function/procedure/class function/class procedure
|
||||
- property, class property, default property
|
||||
- constructor
|
||||
- RTTI
|
||||
- class:
|
||||
- forward declaration
|
||||
- instance.a
|
||||
@ -224,15 +233,7 @@ ToDo:
|
||||
- operator overload
|
||||
- operator enumerator
|
||||
- binaryexpr
|
||||
- advanced records:
|
||||
- $modeswitch AdvancedRecords
|
||||
- sub type
|
||||
- const
|
||||
- var
|
||||
- function/procedure/class function/class procedure
|
||||
- property, class property
|
||||
- RTTI
|
||||
- operator overloading
|
||||
- advanced records
|
||||
- Include/Exclude for set of int/char/bool
|
||||
- error if property method resolution is not used
|
||||
- $H-hintpos$H+
|
||||
@ -5565,6 +5566,21 @@ begin
|
||||
if Proc.IsOverride then
|
||||
RaiseMsg(20180321234551,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'override'],Proc);
|
||||
end;
|
||||
okClassHelper,okRecordHelper,okTypeHelper:
|
||||
if msDelphi in CurrentParser.CurrentModeswitches then
|
||||
begin
|
||||
if Proc.IsAbstract then
|
||||
RaiseMsg(20190116215744,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'abstract'],Proc);
|
||||
if Proc.IsVirtual and (ObjKind=okRecordHelper) then
|
||||
RaiseMsg(20190116221659,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'virtual'],Proc);
|
||||
end
|
||||
else
|
||||
begin
|
||||
if Proc.IsVirtual then
|
||||
RaiseMsg(20190116215823,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'virtual'],Proc);
|
||||
if Proc.IsOverride then
|
||||
RaiseMsg(20190116215825,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'override'],Proc);
|
||||
end;
|
||||
end;
|
||||
if Proc.IsAbstract then
|
||||
begin
|
||||
@ -6698,7 +6714,7 @@ var
|
||||
CanonicalSelf: TPasClassOfType;
|
||||
Decl: TPasElement;
|
||||
j: integer;
|
||||
IntfType, IntfTypeRes: TPasType;
|
||||
IntfType, IntfTypeRes, HelperForType, AncestorHelperFor: TPasType;
|
||||
ResIntfList, Members: TFPList;
|
||||
begin
|
||||
if aClass.IsForward then
|
||||
@ -6742,6 +6758,73 @@ begin
|
||||
RaiseMsg(20180321143613,nIllegalQualifier,sIllegalQualifier,
|
||||
[CurrentParser.Scanner.CurrentValueSwitch[vsInterfaces]],aClass);
|
||||
end;
|
||||
okClassHelper,okRecordHelper,okTypeHelper:
|
||||
begin
|
||||
if aClass.IsExternal then
|
||||
RaiseMsg(20190116192722,nIllegalQualifier,sIllegalQualifier,['external'],aClass);
|
||||
HelperForType:=ResolveAliasType(aClass.HelperForType);
|
||||
case aClass.ObjKind of
|
||||
okClassHelper:
|
||||
begin
|
||||
if not (HelperForType is TPasClassType) then
|
||||
RaiseXExpectedButYFound(20190116194751,'class type',GetTypeDescription(aClass.HelperForType),aClass);
|
||||
if TPasClassType(HelperForType).ObjKind<>okClass then
|
||||
RaiseXExpectedButYFound(20190116194855,'class type',GetTypeDescription(aClass.HelperForType),aClass);
|
||||
if TPasClassType(HelperForType).IsForward then
|
||||
RaiseMsg(20190116194931,nTypeXIsNotYetCompletelyDefined,
|
||||
sTypeXIsNotYetCompletelyDefined,[HelperForType.Name],aClass);
|
||||
end;
|
||||
okRecordHelper:
|
||||
if msDelphi in CurrentParser.CurrentModeswitches then
|
||||
begin
|
||||
if (HelperForType.ClassType=TPasRecordType)
|
||||
or (HelperForType.ClassType=TPasArrayType)
|
||||
or (HelperForType.ClassType=TPasSetType)
|
||||
or (HelperForType.ClassType=TPasEnumType)
|
||||
or (HelperForType.ClassType=TPasRangeType)
|
||||
then
|
||||
// ok
|
||||
else if ((HelperForType.ClassType=TPasUnresolvedSymbolRef)
|
||||
and (HelperForType.CustomData is TResElDataBaseType)) then
|
||||
else
|
||||
RaiseMsg(20190116200304,nTypeXCannotBeExtendedByATypeHelper,
|
||||
sTypeXCannotBeExtendedByATypeHelper,[aClass.HelperForType.Name],aClass);
|
||||
end
|
||||
else
|
||||
begin
|
||||
// mode objfpc
|
||||
if (HelperForType.ClassType=TPasRecordType) then
|
||||
else
|
||||
RaiseMsg(20190116200519,nTypeXCannotBeExtendedByATypeHelper,
|
||||
sTypeXCannotBeExtendedByATypeHelper,[aClass.HelperForType.Name],aClass);
|
||||
end;
|
||||
okTypeHelper:
|
||||
begin
|
||||
if HelperForType.ClassType=TPasUnresolvedSymbolRef then
|
||||
begin
|
||||
if (HelperForType.ClassType=TPasRecordType)
|
||||
or (HelperForType.ClassType=TPasArrayType)
|
||||
or (HelperForType.ClassType=TPasSetType)
|
||||
or (HelperForType.ClassType=TPasEnumType)
|
||||
or (HelperForType.ClassType=TPasRangeType)
|
||||
then
|
||||
// ok
|
||||
else if ((HelperForType.ClassType=TPasUnresolvedSymbolRef)
|
||||
and (HelperForType.CustomData is TResElDataBaseType)) then
|
||||
else if (HelperForType.ClassType=TPasClassType)
|
||||
and (TPasClassType(HelperForType).ObjKind in [okClass,okInterface]) then
|
||||
begin
|
||||
if TPasClassType(HelperForType).IsForward then
|
||||
RaiseMsg(20190116200940,nTypeXIsNotYetCompletelyDefined,
|
||||
sTypeXIsNotYetCompletelyDefined,[HelperForType.Name],aClass);
|
||||
end
|
||||
else
|
||||
RaiseMsg(20190116200304,nTypeXCannotBeExtendedByATypeHelper,
|
||||
sTypeXCannotBeExtendedByATypeHelper,[aClass.HelperForType.Name],aClass);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
RaiseNotYetImplemented(20161010174638,aClass,'Kind='+ObjKindNames[aClass.ObjKind]);
|
||||
end;
|
||||
@ -6804,6 +6887,7 @@ begin
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
okClassHelper,okRecordHelper,okTypeHelper: ; // no root ancestor
|
||||
end;
|
||||
end
|
||||
else if AncestorType.ClassType<>TPasClassType then
|
||||
@ -6814,18 +6898,29 @@ begin
|
||||
begin
|
||||
AncestorClassEl:=TPasClassType(AncestorType);
|
||||
if AncestorClassEl.ObjKind<>aClass.ObjKind then
|
||||
begin
|
||||
RaiseXExpectedButYFound(20180321152107,GetElementTypeName(aClass)+' type',
|
||||
GetElementTypeName(AncestorClassEl)+' type',aClass);
|
||||
end
|
||||
else
|
||||
EmitTypeHints(aClass,AncestorClassEl);
|
||||
if aClass.ObjKind in [okClassHelper,okRecordHelper,okTypeHelper] then
|
||||
begin
|
||||
HelperForType:=ResolveAliasType(aClass.HelperForType);
|
||||
AncestorHelperFor:=ResolveAliasType(AncestorClassEl.HelperForType);
|
||||
if IsSameType(HelperForType,AncestorHelperFor,prraNone) then
|
||||
// helper for same type as ancestor helper -> ok
|
||||
else if (HelperForType is TPasClassType)
|
||||
and (AncestorHelperFor is TPasClassType)
|
||||
and (CheckClassIsClass(HelperForType,AncestorHelperFor,aClass)<>cIncompatible) then
|
||||
// helper is for descendant class of ancestor helper for -> ok
|
||||
else
|
||||
RaiseMsg(20190116203931,nDerivedXMustExtendASubClassY,sDerivedXMustExtendASubClassY,
|
||||
[GetElementTypeName(aClass),AncestorClassEl.HelperForType.Name],aClass);
|
||||
end;
|
||||
EmitTypeHints(aClass,AncestorClassEl);
|
||||
end;
|
||||
|
||||
AncestorClassScope:=nil;
|
||||
if AncestorClassEl=nil then
|
||||
begin
|
||||
// root class e.g. TObject, IUnknown
|
||||
// root class e.g. TObject, IUnknown, helper
|
||||
end
|
||||
else
|
||||
begin
|
||||
|
||||
@ -136,7 +136,7 @@ resourcestring
|
||||
SLogStartImplementation = 'Start parsing implementation section.';
|
||||
SLogStartInterface = 'Start parsing interface section';
|
||||
SParserNoConstructorAllowed = 'Constructors or Destructors are not allowed in Interfaces or Record helpers';
|
||||
SParserNoFieldsAllowed = 'Fields are not allowed in Interfaces';
|
||||
SParserNoFieldsAllowedInX = 'Fields are not allowed in %s';
|
||||
SParserInvalidRecordVisibility = 'Records can only have public and (strict) private as visibility specifiers';
|
||||
SErrRecordConstantsNotAllowed = 'Record constants not allowed at this location.';
|
||||
SErrRecordVariablesNotAllowed = 'Record variables not allowed at this location.';
|
||||
@ -1247,6 +1247,7 @@ begin
|
||||
if not (PM in [pmOverload, pmMessage,
|
||||
pmDispId,pmNoReturn,pmFar,pmFinal]) then exit(false);
|
||||
end;
|
||||
exit;
|
||||
end
|
||||
else if Parent is TPasRecordType then
|
||||
begin
|
||||
@ -1254,6 +1255,7 @@ begin
|
||||
pmInline, pmAssembler,
|
||||
pmExternal,
|
||||
pmNoReturn, pmFar, pmFinal]) then exit(false);
|
||||
exit;
|
||||
end;
|
||||
Parent:=Parent.Parent;
|
||||
end;
|
||||
@ -6690,6 +6692,7 @@ begin
|
||||
LastToken:=CurToken;
|
||||
while (CurToken<>tkEnd) do
|
||||
begin
|
||||
//writeln('TPasParser.ParseClassMembers LastToken=',LastToken,' CurToken=',CurToken,' haveClass=',haveClass,' CurSection=',CurSection);
|
||||
case CurToken of
|
||||
tkType:
|
||||
begin
|
||||
@ -6715,18 +6718,18 @@ begin
|
||||
CurSection:=stConst;
|
||||
end;
|
||||
tkVar:
|
||||
begin
|
||||
case AType.ObjKind of
|
||||
okClass,okObject,okGeneric,
|
||||
okClassHelper,okRecordHelper,okTypeHelper: ;
|
||||
else
|
||||
ParseExc(nParserXNotAllowedInY,SParserXNotAllowedInY,['VAR',ObjKindNames[AType.ObjKind]]);
|
||||
end;
|
||||
if LastToken=tkClass then
|
||||
CurSection:=stClassVar
|
||||
else
|
||||
CurSection:=stVar;
|
||||
end;
|
||||
if not (CurSection in [stVar,stClassVar]) then
|
||||
begin
|
||||
if (AType.ObjKind in [okClass,okObject,okGeneric])
|
||||
or (haveClass and (AType.ObjKind in [okClassHelper,okRecordHelper,okTypeHelper])) then
|
||||
// ok
|
||||
else
|
||||
ParseExc(nParserXNotAllowedInY,SParserXNotAllowedInY,['VAR',ObjKindNames[AType.ObjKind]]);
|
||||
if LastToken=tkClass then
|
||||
CurSection:=stClassVar
|
||||
else
|
||||
CurSection:=stVar;
|
||||
end;
|
||||
tkIdentifier:
|
||||
if CheckVisibility(CurtokenString,CurVisibility) then
|
||||
CurSection:=stNone
|
||||
@ -6740,11 +6743,17 @@ begin
|
||||
stConst :
|
||||
ParseMembersLocalConsts(AType,CurVisibility);
|
||||
stNone,
|
||||
stVar,
|
||||
stVar:
|
||||
begin
|
||||
if not (AType.ObjKind in [okObject,okClass,okGeneric]) then
|
||||
ParseExc(nParserNoFieldsAllowed,SParserNoFieldsAllowedInX,[ObjKindNames[AType.ObjKind]]);
|
||||
ParseClassFields(AType,CurVisibility,CurSection=stClassVar);
|
||||
HaveClass:=False;
|
||||
end;
|
||||
stClassVar:
|
||||
begin
|
||||
if (AType.ObjKind in [okInterface,okDispInterface]) then
|
||||
ParseExc(nParserNoFieldsAllowed,SParserNoFieldsAllowed);
|
||||
if not (AType.ObjKind in [okObject,okClass,okGeneric,okClassHelper,okRecordHelper,okTypeHelper]) then
|
||||
ParseExc(nParserNoFieldsAllowed,SParserNoFieldsAllowedInX,[ObjKindNames[AType.ObjKind]]);
|
||||
ParseClassFields(AType,CurVisibility,CurSection=stClassVar);
|
||||
HaveClass:=False;
|
||||
end;
|
||||
@ -6757,7 +6766,11 @@ begin
|
||||
curSection:=stNone;
|
||||
if not haveClass then
|
||||
SaveComments;
|
||||
if AType.ObjKind in [okInterface,okDispInterface,okRecordHelper] then
|
||||
if (AType.ObjKind in [okObject,okClass,okGeneric])
|
||||
or ((CurToken=tkconstructor)
|
||||
and (AType.ObjKind in [okClassHelper,okTypeHelper,okRecordHelper])) then
|
||||
// ok
|
||||
else
|
||||
ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed);
|
||||
ProcessMethod(AType,HaveClass,CurVisibility);
|
||||
haveClass:=False;
|
||||
|
||||
@ -860,6 +860,16 @@ type
|
||||
Procedure TestHint_ElementHints_WarnOff_SymbolDeprecated;
|
||||
Procedure TestHint_Garbage;
|
||||
|
||||
// helpers
|
||||
Procedure ClassHelper;
|
||||
Procedure ClassHelper_AncestorIsNotHelperForDescendantFail;
|
||||
Procedure ClassHelper_ForInterfaceFail;
|
||||
Procedure ClassHelper_FieldFail;
|
||||
Procedure ClassHelper_AbstractFail;
|
||||
Procedure ClassHelper_VirtualObjFPCFail;
|
||||
Procedure RecordHelper;
|
||||
Procedure TypeHelper;
|
||||
|
||||
// attributes
|
||||
Procedure TestAttributes_Ignore;
|
||||
end;
|
||||
@ -12148,7 +12158,7 @@ begin
|
||||
' i: longint;',
|
||||
' end;',
|
||||
'begin']);
|
||||
CheckParserException(SParserNoFieldsAllowed,nParserNoFieldsAllowed);
|
||||
CheckParserException('Fields are not allowed in interface',nParserNoFieldsAllowed);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestClassInterfaceConstFail;
|
||||
@ -12249,7 +12259,7 @@ begin
|
||||
' procedure DoIt; virtual;',
|
||||
' end;',
|
||||
'begin']);
|
||||
CheckParserException(sParserNoFieldsAllowed,nParserNoFieldsAllowed);
|
||||
CheckParserException('Fields are not allowed in interface',nParserNoFieldsAllowed);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestClassInterface_Overloads;
|
||||
@ -15486,6 +15496,162 @@ begin
|
||||
CheckResolverUnexpectedHints(true);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.ClassHelper;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'type',
|
||||
' TObject = class',
|
||||
' end;',
|
||||
' TObjectHelper = class helper for TObject',
|
||||
' type T = word;',
|
||||
' const',
|
||||
' c: T = 3;',
|
||||
' k: T = 4;',
|
||||
' class var',
|
||||
' v: T;',
|
||||
' w: T;',
|
||||
' end;',
|
||||
' TBird = class(TObject)',
|
||||
' end;',
|
||||
' TBirdHelper = class helper for TBird',
|
||||
' end;',
|
||||
' TExtObjHelper = class helper(TObjectHelper) for TBird',
|
||||
' end;',
|
||||
'begin',
|
||||
'']);
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.ClassHelper_AncestorIsNotHelperForDescendantFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'type',
|
||||
' TObject = class',
|
||||
' end;',
|
||||
' TBird = class(TObject)',
|
||||
' end;',
|
||||
' TBirdHelper = class helper for TBird',
|
||||
' end;',
|
||||
' TFish = class(TObject)',
|
||||
' end;',
|
||||
' THelper = class helper(TBirdHelper) for TFish',
|
||||
' end;',
|
||||
'begin',
|
||||
'']);
|
||||
CheckResolverException('Derived class helper must extend a subclass of "TBird" or the class itself',
|
||||
nDerivedXMustExtendASubClassY);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.ClassHelper_ForInterfaceFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'type',
|
||||
' IUnknown = interface',
|
||||
' procedure DoIt;',
|
||||
' end;',
|
||||
' TBirdHelper = class helper for IUnknown',
|
||||
' end;',
|
||||
'begin',
|
||||
'']);
|
||||
CheckResolverException('class type expected, but IUnknown found',
|
||||
nXExpectedButYFound);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.ClassHelper_FieldFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'type',
|
||||
' TObject = class',
|
||||
' end;',
|
||||
' TObjHelper = class helper for TObject',
|
||||
' F: word;',
|
||||
' end;',
|
||||
'begin',
|
||||
'']);
|
||||
CheckParserException('Fields are not allowed in class helper',
|
||||
nParserNoFieldsAllowed);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.ClassHelper_AbstractFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$mode delphi}',
|
||||
'type',
|
||||
' TObject = class',
|
||||
' end;',
|
||||
' TObjHelper = class helper for TObject',
|
||||
' procedure DoIt; virtual; abstract;',
|
||||
' end;',
|
||||
'begin',
|
||||
'']);
|
||||
CheckResolverException('Invalid class helper procedure modifier abstract',
|
||||
nInvalidXModifierY);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.ClassHelper_VirtualObjFPCFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'type',
|
||||
' TObject = class',
|
||||
' end;',
|
||||
' TObjHelper = class helper for TObject',
|
||||
' procedure DoIt; virtual;',
|
||||
' end;',
|
||||
'procedure TObjHelper.DoIt;',
|
||||
'begin end;',
|
||||
'begin',
|
||||
'']);
|
||||
CheckResolverException('Invalid class helper procedure modifier virtual',
|
||||
nInvalidXModifierY);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.RecordHelper;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$mode delphi}',
|
||||
'type',
|
||||
' TRec = record',
|
||||
' end;',
|
||||
' TRecHelper = record helper for TRec',
|
||||
' type T = word;',
|
||||
' const',
|
||||
' c: T = 3;',
|
||||
' k: T = 4;',
|
||||
' class var',
|
||||
' v: T;',
|
||||
' w: T;',
|
||||
' end;',
|
||||
' TAnt = word;',
|
||||
' TAntHelper = record helper for TAnt',
|
||||
' end;',
|
||||
'begin',
|
||||
'']);
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TypeHelper;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$modeswitch typehelpers}',
|
||||
'type',
|
||||
' TStringHelper = type helper for string',
|
||||
' end;',
|
||||
' TCaption = string;',
|
||||
' TCapHelper = type helper(TStringHelper) for TCaption',
|
||||
' end;',
|
||||
'begin',
|
||||
'']);
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestAttributes_Ignore;
|
||||
begin
|
||||
StartProgram(false);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user