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

fcl-passrc: TPasClassType and TPasRecordType now have common ancestor, resolver: started advancedrecord methods

Browse Source 
git-svn-id: trunk@40591 -
This commit is contained in:
Mattias Gaertner 2018-12-18 22:19:43 +00:00
parent 883f832263
commit 0043b747c7
8 changed files with 392 additions and 216 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -134,7 +134,7 @@ const
nFoundCallCandidateX = 3057;
nTextAfterFinalIgnored = 3058;
nNoMemberIsProvidedToAccessProperty = 3059;
// free 3060
nTheUseOfXisNotAllowedInARecord = 3060;
// free 3061
// free 3062
// free 3063
@ -251,6 +251,7 @@ resourcestring
sFoundCallCandidateX = 'Found call candidate %s';
sTextAfterFinalIgnored = 'Text after final ''end.''. ignored by compiler';
sNoMemberIsProvidedToAccessProperty = 'No member is provided to access property';
sTheUseOfXisNotAllowedInARecord = 'The use of "%s" is not allowed in a record';
sSymbolXIsNotPortable = 'Symbol "%s" is not portable';
sSymbolXIsExperimental = 'Symbol "%s" is experimental';
sSymbolXIsNotImplemented = 'Symbol "%s" is not implemented';

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

@ -216,14 +216,24 @@ Works:
- pass as arg doit(procedure begin end)
- modifiers assembler varargs cdecl
- typecast
- with
- self
- built-in procedure Val(const s: string; var e: enumtype; out Code: integertype);
ToDo:
- anonymous methods:
- with
- self
- 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
- Include/Exclude for set of int/char/bool
- set of CharRange
- error if property method resolution is not used
- $H-hintpos$H+
- $pop, $push
@ -235,13 +245,12 @@ ToDo:
- proc: check if forward and impl default values match
- call array of proc without ()
- attributes
- object
- type helpers
- record/class helpers
- array of const
- generics, nested param lists
- object
- futures
- operator overload
- operator enumerator
- TPasFileType
- labels
- $zerobasedstrings on|off
@ -838,9 +847,16 @@ type
destructor Destroy; override;
end;
{ TPasClassOrRecordScope }
TPasClassOrRecordScope = Class(TPasIdentifierScope)
public
DefaultProperty: TPasProperty;
end;
{ TPasRecordScope }
TPasRecordScope = Class(TPasIdentifierScope)
TPasRecordScope = Class(TPasClassOrRecordScope)
end;
TPasClassScopeFlag = (
@ -863,12 +879,11 @@ type
{ TPasClassScope }
TPasClassScope = Class(TPasIdentifierScope)
TPasClassScope = Class(TPasClassOrRecordScope)
public
AncestorScope: TPasClassScope;
CanonicalClassOf: TPasClassOfType;
DirectAncestor: TPasType; // TPasClassType or TPasAliasType, see GetPasClassAncestor
DefaultProperty: TPasProperty;
Flags: TPasClassScopeFlags;
AbstractProcs: TArrayOfPasProcedure;
Interfaces: TFPList; // list corresponds to TPasClassType(Element).Interfaces,
@ -894,7 +909,7 @@ type
DeclarationProc: TPasProcedure; // the corresponding forward declaration
ImplProc: TPasProcedure; // the corresponding proc with Body
OverriddenProc: TPasProcedure; // if IsOverride then this is the ancestor proc (virtual or override)
ClassScope: TPasClassScope;
ClassScope: TPasClassOrRecordScope;
SelfArg: TPasArgument;
Flags: TPasProcedureScopeFlags;
BoolSwitches: TBoolSwitches; // if Body<>nil then body start, otherwise when FinishProc
@ -1424,7 +1439,7 @@ type
procedure FinishWithDo(El: TPasImplWithDo); virtual;
procedure FinishDeclaration(El: TPasElement); virtual;
procedure FinishVariable(El: TPasVariable); virtual;
procedure FinishPropertyOfClass(PropEl: TPasProperty); virtual;
procedure FinishProperty(PropEl: TPasProperty); virtual;
procedure FinishArgument(El: TPasArgument); virtual;
procedure FinishAncestors(aClass: TPasClassType); virtual;
procedure FinishMethodResolution(El: TPasMethodResolution); virtual;
@ -4298,7 +4313,7 @@ begin
else
begin
// give a hint
if Data^.Proc.Parent is TPasClassType then
if Data^.Proc.Parent is TPasMembersType then
LogMsg(20171118205344,mtHint,nFunctionHidesIdentifier_NonProc,sFunctionHidesIdentifier,
[GetElementSourcePosStr(El)],Data^.Proc.ProcType);
end;
@ -4397,7 +4412,7 @@ begin
begin
// Delphi/FPC do not give a message when hiding a non virtual method
// -> emit Hint with other message id
if (Data^.Proc.Parent is TPasClassType) then
if (Data^.Proc.Parent is TPasMembersType) then
begin
ProcScope:=Proc.CustomData as TPasProcedureScope;
if (ProcScope.ImplProc<>nil) // not abstract, external
@ -4920,7 +4935,7 @@ begin
else if (C=TPasAliasType) or (C=TPasTypeAliasType) then
begin
aType:=ResolveAliasType(El);
if (aType is TPasClassType) and (aType.CustomData=nil) then
if (aType is TPasMembersType) and (aType.CustomData=nil) then
exit;
EmitTypeHints(El,TPasAliasType(El).DestType);
end
@ -5423,6 +5438,22 @@ begin
if (Proc.ClassType<>TPasClassProcedure) and (Proc.ClassType<>TPasClassFunction) then
RaiseMsg(20170216151631,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'static'],Proc);
end
else if Proc.Parent is TPasRecordType then
begin
if Proc.IsReintroduced then
RaiseMsg(20181218195735,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'reintroduce'],Proc);
if Proc.IsVirtual then
RaiseMsg(20181218195431,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'virtual'],Proc);
if Proc.IsOverride then
RaiseMsg(20181218195437,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'override'],Proc);
if Proc.IsAbstract then
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(20181218195519,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'static'],Proc);
end
else
begin
// intf proc, forward proc, proc body, method body, anonymous proc
@ -5466,7 +5497,7 @@ begin
if Proc.LibrarySymbolName<>nil then
ResolveExpr(Proc.LibrarySymbolName,rraRead);
if Proc.Parent is TPasClassType then
if Proc.Parent is TPasMembersType then
begin
FinishMethodDeclHeader(Proc);
exit;
@ -5581,7 +5612,7 @@ procedure TPasResolver.FinishMethodDeclHeader(Proc: TPasProcedure);
var
Abort: boolean;
ClassScope: TPasClassScope;
ClassOrRecScope: TPasClassOrRecordScope;
FindData: TFindOverloadProcData;
OverloadProc: TPasProcedure;
ProcScope: TPasProcedureScope;
@ -5591,14 +5622,14 @@ begin
ProcScope:=TopScope as TPasProcedureScope;
// ToDo: store the scanner flags *before* it has parsed the token after the proc
StoreScannerFlagsInProc(ProcScope);
ClassScope:=Scopes[ScopeCount-2] as TPasClassScope;
ProcScope.ClassScope:=ClassScope;
ClassOrRecScope:=Scopes[ScopeCount-2] as TPasClassOrRecordScope;
ProcScope.ClassScope:=ClassOrRecScope;
FindData:=Default(TFindOverloadProcData);
FindData.Proc:=Proc;
FindData.Args:=Proc.ProcType.Args;
FindData.Kind:=fopkMethod;
Abort:=false;
ClassScope.IterateElements(Proc.Name,ClassScope,@OnFindOverloadProc,@FindData,Abort);
ClassOrRecScope.IterateElements(Proc.Name,ClassOrRecScope,@OnFindOverloadProc,@FindData,Abort);
if FindData.Found=nil then
begin
@ -5643,24 +5674,25 @@ begin
if proFixCaseOfOverrides in Options then
Proc.Name:=OverloadProc.Name;
// remove abstract
if OverloadProc.IsAbstract then
for i:=length(ClassScope.AbstractProcs)-1 downto 0 do
if ClassScope.AbstractProcs[i]=OverloadProc then
Delete(ClassScope.AbstractProcs,i,1);
if OverloadProc.IsAbstract and (ClassOrRecScope is TPasClassScope) then
for i:=length(TPasClassScope(ClassOrRecScope).AbstractProcs)-1 downto 0 do
if TPasClassScope(ClassOrRecScope).AbstractProcs[i]=OverloadProc then
Delete(TPasClassScope(ClassOrRecScope).AbstractProcs,i,1);
end;
end;
// add abstract
if Proc.IsAbstract then
Insert(Proc,ClassScope.AbstractProcs,length(ClassScope.AbstractProcs));
if Proc.IsAbstract and (ClassOrRecScope is TPasClassScope) then
Insert(Proc,TPasClassScope(ClassOrRecScope).AbstractProcs,
length(TPasClassScope(ClassOrRecScope).AbstractProcs));
end;
procedure TPasResolver.FinishMethodImplHeader(ImplProc: TPasProcedure);
var
ProcName: String;
CurClassType: TPasClassType;
ClassRecType: TPasMembersType;
ImplProcScope, DeclProcScope: TPasProcedureScope;
DeclProc: TPasProcedure;
CurClassScope: TPasClassScope;
CurClassRecScope: TPasClassOrRecordScope;
SelfArg: TPasArgument;
p: Integer;
begin
@ -5685,14 +5717,14 @@ begin
if not IsValidIdent(ProcName) then
RaiseNotYetImplemented(20160922163421,ImplProc.ProcType);
// search proc in class
// search proc in class/record
ImplProcScope:=ImplProc.CustomData as TPasProcedureScope;
CurClassScope:=ImplProcScope.ClassScope;
if CurClassScope=nil then
CurClassRecScope:=ImplProcScope.ClassScope;
if CurClassRecScope=nil then
RaiseInternalError(20161013172346);
CurClassType:=NoNil(CurClassScope.Element) as TPasClassType;
ClassRecType:=NoNil(CurClassRecScope.Element) as TPasMembersType;
DeclProc:=FindProcOverload(ProcName,ImplProc,CurClassScope);
DeclProc:=FindProcOverload(ProcName,ImplProc,CurClassRecScope);
if DeclProc=nil then
RaiseIdentifierNotFound(20170216151720,ImplProc.Name,ImplProc.ProcType);
DeclProcScope:=DeclProc.CustomData as TPasProcedureScope;
@ -5721,14 +5753,14 @@ begin
or (DeclProc.ClassType=TPasClassProcedure)
or (DeclProc.ClassType=TPasClassFunction) then
begin
if not DeclProc.IsStatic then
if (not DeclProc.IsStatic) and (CurClassRecScope is TPasClassScope) then
begin
// 'Self' in a class proc is the hidden classtype argument
SelfArg:=TPasArgument.Create('Self',DeclProc);
ImplProcScope.SelfArg:=SelfArg;
{$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF}
SelfArg.Access:=argConst;
SelfArg.ArgType:=CurClassScope.CanonicalClassOf;
SelfArg.ArgType:=TPasClassScope(CurClassRecScope).CanonicalClassOf;
SelfArg.ArgType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF};
AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple);
end;
@ -5740,8 +5772,8 @@ begin
ImplProcScope.SelfArg:=SelfArg;
{$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF}
SelfArg.Access:=argConst;
SelfArg.ArgType:=CurClassType;
CurClassType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF};
SelfArg.ArgType:=ClassRecType;
ClassRecType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF};
AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple);
end;
end;
@ -5783,7 +5815,7 @@ begin
if (C=TPasVariable) or (C=TPasConst) then
FinishVariable(TPasVariable(El))
else if C=TPasProperty then
FinishPropertyOfClass(TPasProperty(El))
FinishProperty(TPasProperty(El))
else if C=TPasArgument then
FinishArgument(TPasArgument(El))
else if C=TPasMethodResolution then
@ -5812,6 +5844,9 @@ begin
ResolveExpr(El.Expr,rraRead);
if El.VarType<>nil then
begin
if (El.Parent is TPasRecordType) and (El.VarType=El.Parent) then
RaiseMsg(20181218173631,nTypeXIsNotYetCompletelyDefined,
sTypeXIsNotYetCompletelyDefined,[El.VarType.Name],El);
if El.Expr<>nil then
CheckAssignCompatibility(El,El.Expr,true);
end
@ -5855,7 +5890,7 @@ begin
EmitTypeHints(El,El.VarType);
end;
procedure TPasResolver.FinishPropertyOfClass(PropEl: TPasProperty);
procedure TPasResolver.FinishProperty(PropEl: TPasProperty);
var
PropType: TPasType;
ClassScope: TPasClassScope;
@ -6750,7 +6785,7 @@ begin
CreateReference(IntfProc,Expr,rraRead);
if IntfProc.ClassType<>El.ProcClass then
RaiseXExpectedButYFound(20180323144107,GetElementTypeName(El.ProcClass),GetElementTypeName(IntfProc),El.InterfaceProc);
// Note: do not create map here. CheckImplements in FinishPropertyOfClass must be called before.
// Note: do not create map here. CheckImplements in FinishProperty must be called before.
// El.ImplementationProc is resolved in FinishClassType
end;
@ -7863,7 +7898,7 @@ begin
// identifier is a proc and args brackets are missing
if El.Parent.ClassType=TPasProperty then
// a property accessor does not need args -> ok
// Note: the detailed tests are in FinishPropertyOfClass
// Note: the detailed tests are in FinishProperty
else
begin
// examples: funca or @proca or a.funca or @a.funca ...
@ -7936,7 +7971,8 @@ procedure TPasResolver.ResolveInherited(El: TInheritedExpr;
Access: TResolvedRefAccess);
var
ProcScope, DeclProcScope, SelfScope: TPasProcedureScope;
AncestorScope, ClassScope: TPasClassScope;
AncestorScope: TPasClassScope;
ClassRecScope: TPasClassOrRecordScope;
DeclProc, AncestorProc: TPasProcedure;
begin
{$IFDEF VerbosePasResolver}
@ -7955,13 +7991,24 @@ begin
SelfScope:=ProcScope.GetSelfScope;
if SelfScope=nil then
RaiseMsg(20170216152141,nInheritedOnlyWorksInMethods,sInheritedOnlyWorksInMethods,[],El);
ClassScope:=SelfScope.ClassScope;
ClassRecScope:=SelfScope.ClassScope;
AncestorScope:=ClassScope.AncestorScope;
if AncestorScope=nil then
AncestorScope:=nil;
if ClassRecScope is TPasClassScope then
begin
// 'inherited;' without ancestor class is silently ignored
exit;
// inherited in class method
AncestorScope:=TPasClassScope(ClassRecScope).AncestorScope;
if AncestorScope=nil then
begin
// 'inherited;' without ancestor class is silently ignored
exit;
end;
end
else
begin
// inherited in record method
RaiseMsg(20181218194022,nTheUseOfXisNotAllowedInARecord,sTheUseOfXisNotAllowedInARecord,
['inherited'],El);
end;
// search ancestor in element, i.e. 'inherited' expression
@ -7986,7 +8033,8 @@ procedure TPasResolver.ResolveInheritedCall(El: TBinaryExpr;
// El.right is the identifier and parameters
var
ProcScope, SelfScope: TPasProcedureScope;
AncestorScope, ClassScope: TPasClassScope;
AncestorScope: TPasClassScope;
ClassRecScope: TPasClassOrRecordScope;
AncestorClass: TPasClassType;
InhScope: TPasDotClassScope;
begin
@ -7998,11 +8046,22 @@ begin
SelfScope:=ProcScope.GetSelfScope;
if SelfScope=nil then
RaiseMsg(20170216152148,nInheritedOnlyWorksInMethods,sInheritedOnlyWorksInMethods,[],El);
ClassScope:=SelfScope.ClassScope;
ClassRecScope:=SelfScope.ClassScope;
AncestorScope:=ClassScope.AncestorScope;
if AncestorScope=nil then
RaiseMsg(20170216152151,nInheritedNeedsAncestor,sInheritedNeedsAncestor,[],El.left);
AncestorScope:=nil;
if ClassRecScope is TPasClassScope then
begin
// inherited in class method
AncestorScope:=TPasClassScope(ClassRecScope).AncestorScope;
if AncestorScope=nil then
RaiseMsg(20170216152151,nInheritedNeedsAncestor,sInheritedNeedsAncestor,[],El.left);
end
else
begin
// inherited in record method
RaiseMsg(20181218194436,nTheUseOfXisNotAllowedInARecord,sTheUseOfXisNotAllowedInARecord,
['inherited'],El);
end;
// search call in ancestor
AncestorClass:=TPasClassType(AncestorScope.Element);
@ -9325,12 +9384,12 @@ procedure TPasResolver.AddProcedure(El: TPasProcedure);
var
ProcName, aClassName: String;
p: SizeInt;
CurClassType: TPasClassType;
ClassOrRecType: TPasMembersType;
ProcScope: TPasProcedureScope;
HasDot: Boolean;
CurEl: TPasElement;
Identifier: TPasIdentifier;
CurClassScope: TPasClassScope;
ClassOrRecScope: TPasClassOrRecordScope;
C: TClass;
begin
{$IFDEF VerbosePasResolver}
@ -9370,12 +9429,12 @@ begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.AddProcedure searching class of "',ProcName,'" ...');
{$ENDIF}
CurClassType:=nil;
ClassOrRecType:=nil;
repeat
p:=Pos('.',ProcName);
if p<1 then
begin
if CurClassType=nil then
if ClassOrRecType=nil then
RaiseInternalError(20161013170829);
break;
end;
@ -9387,10 +9446,10 @@ begin
if not IsValidIdent(aClassName) then
RaiseNotYetImplemented(20161013170844,El);
if CurClassType<>nil then
if ClassOrRecType<>nil then
begin
CurClassScope:=TPasClassScope(CurClassType.CustomData);
Identifier:=CurClassScope.FindLocalIdentifier(aClassName);
ClassOrRecScope:=TPasClassOrRecordScope(ClassOrRecType.CustomData);
Identifier:=ClassOrRecScope.FindLocalIdentifier(aClassName);
if Identifier=nil then
RaiseIdentifierNotFound(20180430130635,aClassName,El);
CurEl:=Identifier.Element;
@ -9398,7 +9457,7 @@ begin
else
CurEl:=FindElementWithoutParams(aClassName,El,false);
if not (CurEl is TPasClassType) then
if not (CurEl is TPasMembersType) then
begin
aClassName:=LeftStr(El.Name,length(El.Name)-length(ProcName)-1);
{$IFDEF VerbosePasResolver}
@ -9407,26 +9466,29 @@ begin
RaiseXExpectedButYFound(20170216152557,
'class',aClassname+':'+GetElementTypeName(CurEl),El);
end;
CurClassType:=TPasClassType(CurEl);
if CurClassType.ObjKind<>okClass then
ClassOrRecType:=TPasMembersType(CurEl);
if ClassOrRecType is TPasClassType then
begin
aClassName:=LeftStr(El.Name,length(El.Name)-length(ProcName)-1);
RaiseXExpectedButYFound(20180321161722,
'class',aClassname+':'+GetElementTypeName(CurEl),El);
if TPasClassType(ClassOrRecType).ObjKind<>okClass then
begin
aClassName:=LeftStr(El.Name,length(El.Name)-length(ProcName)-1);
RaiseXExpectedButYFound(20180321161722,
'class',aClassname+':'+GetElementTypeName(CurEl),El);
end
end;
if CurClassType.GetModule<>El.GetModule then
if ClassOrRecType.GetModule<>El.GetModule then
begin
aClassName:=LeftStr(El.Name,length(El.Name)-length(ProcName)-1);
RaiseMsg(20180211230432,nMethodClassXInOtherUnitY,sMethodClassXInOtherUnitY,
[aClassName,CurClassType.GetModule.Name],El);
[aClassName,ClassOrRecType.GetModule.Name],El);
end;
until false;
if not IsValidIdent(ProcName) then
RaiseNotYetImplemented(20161013170956,El);
ProcScope.VisibilityContext:=CurClassType;
ProcScope.ClassScope:=NoNil(CurClassType.CustomData) as TPasClassScope;
ProcScope.VisibilityContext:=ClassOrRecType;
ProcScope.ClassScope:=NoNil(ClassOrRecType.CustomData) as TPasClassOrRecordScope;
end;// HasDot=true
end;
@ -14576,8 +14638,9 @@ var
OnlyTypeMembers, IsClassOf: Boolean;
TypeEl: TPasType;
C: TClass;
ClassScope: TPasClassScope;
ClassRecScope: TPasClassOrRecordScope;
i: Integer;
AbstractProcs: TArrayOfPasProcedure;
begin
StartScope:=FindData.StartScope;
OnlyTypeMembers:=false;
@ -14694,25 +14757,29 @@ begin
RaiseInternalError(20170131141936);
Ref.Context:=TResolvedRefCtxConstructor.Create;
if StartScope is TPasDotClassScope then
ClassScope:=TPasDotClassScope(StartScope).ClassScope
ClassRecScope:=TPasDotClassScope(StartScope).ClassScope
else if (StartScope is TPasWithExprScope)
and (TPasWithExprScope(StartScope).Scope is TPasClassScope) then
ClassScope:=TPasClassScope(TPasWithExprScope(StartScope).Scope)
and (TPasWithExprScope(StartScope).Scope is TPasClassOrRecordScope) then
ClassRecScope:=TPasClassOrRecordScope(TPasWithExprScope(StartScope).Scope)
else if (StartScope is TPasProcedureScope) then
ClassScope:=TPasProcedureScope(StartScope).ClassScope
ClassRecScope:=TPasProcedureScope(StartScope).ClassScope
else
RaiseInternalError(20170131150855,GetObjName(StartScope));
TypeEl:=ClassScope.Element as TPasType;
TypeEl:=ClassRecScope.Element as TPasType;
TResolvedRefCtxConstructor(Ref.Context).Typ:=TypeEl;
if (length(ClassScope.AbstractProcs)>0) then
if ClassRecScope is TPasClassScope then
begin
if IsClassOf then
// aClass.Create: do not warn
else
for i:=0 to length(ClassScope.AbstractProcs)-1 do
LogMsg(20171227110746,mtWarning,nConstructingClassXWithAbstractMethodY,
sConstructingClassXWithAbstractMethodY,
[TypeEl.Name,ClassScope.AbstractProcs[i].Name],FindData.ErrorPosEl);
AbstractProcs:=TPasClassScope(ClassRecScope).AbstractProcs;
if (length(AbstractProcs)>0) then
begin
if IsClassOf then
// aClass.Create: do not warn
else
for i:=0 to length(AbstractProcs)-1 do
LogMsg(20171227110746,mtWarning,nConstructingClassXWithAbstractMethodY,
sConstructingClassXWithAbstractMethodY,
[TypeEl.Name,AbstractProcs[i].Name],FindData.ErrorPosEl);
end;
end;
end;
{$IFDEF VerbosePasResolver}
@ -20528,7 +20595,7 @@ var
begin
Result:=false;
if El=nil then exit;
if El.Parent is TPasClassType then exit(true);
if El.Parent is TPasMembersType then exit(true);
if not (El.CustomData is TPasProcedureScope) then exit;
ProcScope:=TPasProcedureScope(El.CustomData);
Result:=IsMethod(ProcScope.DeclarationProc);

225
packages/fcl-passrc/src/pastree.pp
View File

@ -692,14 +692,31 @@ type
Members: TPasRecordType;
end;
{ TPasRecordType }
{ TPasMembersType - base type for TPasRecordType and TPasClassType }
TPasRecordType = class(TPasType)
TPasMembersType = class(TPasType)
private
procedure ClearChildReferences(El: TPasElement; arg: pointer);
procedure GetMembers(S: TStrings);
protected
procedure SetParent(const AValue: TPasElement); override;
public
PackMode: TPackMode;
Members: TFPList;
GenericTemplateTypes: TFPList; // list of TPasGenericTemplateType
Constructor Create(const AName: string; AParent: TPasElement); override;
Destructor Destroy; override;
Function IsPacked: Boolean;
Function IsBitPacked : Boolean;
Procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer); override;
Procedure SetGenericTemplates(AList: TFPList); virtual;
end;
{ TPasRecordType }
TPasRecordType = class(TPasMembersType)
private
procedure GetMembers(S: TStrings);
public
constructor Create(const AName: string; AParent: TPasElement); override;
destructor Destroy; override;
@ -708,15 +725,9 @@ type
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer); override;
public
PackMode: TPackMode;
Members: TFPList; // list of TPasVariable elements
VariantEl: TPasElement; // nil or TPasVariable or TPasType
Variants: TFPList; // list of TPasVariant elements, may be nil!
GenericTemplateTypes: TFPList; // list of TPasGenericTemplateType
Function IsPacked: Boolean;
Function IsBitPacked : Boolean;
Function IsAdvancedRecord : Boolean;
Procedure SetGenericTemplates(AList : TFPList);
end;
TPasGenericTemplateType = Class(TPasType);
@ -734,9 +745,7 @@ type
{ TPasClassType }
TPasClassType = class(TPasType)
private
procedure ClearChildReferences(El: TPasElement; arg: pointer);
TPasClassType = class(TPasMembersType)
protected
procedure SetParent(const AValue: TPasElement); override;
public
@ -746,7 +755,6 @@ type
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer); override;
public
PackMode: TPackMode;
ObjKind: TPasObjKind;
AncestorType: TPasType; // TPasClassType or TPasUnresolvedTypeRef or TPasAliasType or TPasTypeAliasType
// Note: AncestorType can be nil even though it has a default ancestor
@ -755,25 +763,20 @@ type
IsExternal : Boolean;
IsShortDefinition: Boolean;//class(anchestor); without end
GUIDExpr : TPasExpr;
Members: TFPList; // list of TPasElement
Modifiers: TStringList;
Interfaces : TFPList; // list of TPasType
GenericTemplateTypes: TFPList; // list of TPasGenericTemplateType
ExternalNameSpace : String;
ExternalName : String;
InterfaceType: TPasClassInterfaceType;
Procedure SetGenericTemplates(AList : TFPList);
Procedure SetGenericTemplates(AList : TFPList); override;
Function FindMember(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;
Function FindMemberInAncestors(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;
Function IsPacked : Boolean;
Function InterfaceGUID : string;
Function IsSealed : Boolean;
Function IsAbstract : Boolean;
Function HasModifier(const aModifier: String): Boolean;
end;
TArgumentAccess = (argDefault, argConst, argVar, argOut, argConstRef);
{ TPasArgument }
@ -2948,22 +2951,12 @@ end;
constructor TPasRecordType.Create(const AName: string; AParent: TPasElement);
begin
inherited Create(AName, AParent);
Members := TFPList.Create;
GenericTemplateTypes:=TFPList.Create;
end;
destructor TPasRecordType.Destroy;
var
i: Integer;
begin
for i := 0 to GenericTemplateTypes.Count - 1 do
TPasElement(GenericTemplateTypes[i]).Release{$IFDEF CheckPasTreeRefCount}('TPasRecordType.GenericTemplateTypes'){$ENDIF};
FreeAndNil(GenericTemplateTypes);
for i := 0 to Members.Count - 1 do
TPasVariable(Members[i]).Release{$IFDEF CheckPasTreeRefCount}('TPasRecordType.Members'){$ENDIF};
FreeAndNil(Members);
ReleaseAndNil(TPasElement(VariantEl){$IFDEF CheckPasTreeRefCount},'TPasRecordType.VariantEl'{$ENDIF});
if Assigned(Variants) then
@ -2978,19 +2971,12 @@ end;
{ TPasClassType }
procedure TPasClassType.ClearChildReferences(El: TPasElement; arg: pointer);
begin
El.ClearTypeReferences(Self);
if arg=nil then ;
end;
procedure TPasClassType.SetParent(const AValue: TPasElement);
begin
if (AValue=nil) and (Parent<>nil) then
begin
// parent is cleared
// -> clear all child references to this class (releasing loops)
ForEachCall(@ClearChildReferences,nil);
// -> clear all references to this class (releasing loops)
if AncestorType=Self then
ReleaseAndNil(TPasElement(AncestorType){$IFDEF CheckPasTreeRefCount},'TPasClassType.AncestorType'{$ENDIF});
if HelperForType=Self then
@ -3002,27 +2988,15 @@ end;
constructor TPasClassType.Create(const AName: string; AParent: TPasElement);
begin
inherited Create(AName, AParent);
PackMode:=pmNone; // 12/04/04 - Dave - Added
IsShortDefinition := False;
Members := TFPList.Create;
Modifiers := TStringList.Create;
Interfaces:= TFPList.Create;
GenericTemplateTypes:=TFPList.Create;
end;
destructor TPasClassType.Destroy;
var
i: Integer;
El: TPasElement;
begin
for i := 0 to Members.Count - 1 do
begin
El:=TPasElement(Members[i]);
El.Parent:=nil;
El.Release{$IFDEF CheckPasTreeRefCount}('TPasClassType.Members'){$ENDIF};
end;
FreeAndNil(Members);
for i := 0 to Interfaces.Count - 1 do
TPasElement(Interfaces[i]).Release{$IFDEF CheckPasTreeRefCount}('TPasClassType.Interfaces'){$ENDIF};
FreeAndNil(Interfaces);
@ -3030,9 +3004,6 @@ begin
ReleaseAndNil(TPasElement(HelperForType){$IFDEF CheckPasTreeRefCount},'TPasClassType.HelperForType'{$ENDIF});
ReleaseAndNil(TPasElement(GUIDExpr){$IFDEF CheckPasTreeRefCount},'TPasClassType.GUIDExpr'{$ENDIF});
FreeAndNil(Modifiers);
for i := 0 to GenericTemplateTypes.Count - 1 do
TPasElement(GenericTemplateTypes[i]).Release{$IFDEF CheckPasTreeRefCount}('TPasClassType.GenericTemplateTypes'){$ENDIF};
FreeAndNil(GenericTemplateTypes);
inherited Destroy;
end;
@ -3062,26 +3033,12 @@ begin
ForEachChildCall(aMethodCall,Arg,TPasElement(Interfaces[i]),true);
ForEachChildCall(aMethodCall,Arg,HelperForType,true);
ForEachChildCall(aMethodCall,Arg,GUIDExpr,false);
for i:=0 to Members.Count-1 do
ForEachChildCall(aMethodCall,Arg,TPasElement(Members[i]),false);
for i:=0 to GenericTemplateTypes.Count-1 do
ForEachChildCall(aMethodCall,Arg,TPasElement(GenericTemplateTypes[i]),false);
end;
procedure TPasClassType.SetGenericTemplates(AList: TFPList);
Var
I : Integer;
begin
ObjKind:=okGeneric;
For I:=0 to AList.Count-1 do
begin
TPasElement(AList[i]).Parent:=Self;
GenericTemplateTypes.Add(AList[i]);
end;
AList.Clear;
ObjKind:=okGeneric;
inherited SetGenericTemplates(AList);
end;
function TPasClassType.FindMember(MemberClass: TPTreeElement; const MemberName: String): TPasElement;
@ -3155,12 +3112,6 @@ begin
Result:=false;
end;
function TPasClassType.IsPacked: Boolean;
begin
Result:=PackMode<>pmNone;
end;
{ TPasArgument }
destructor TPasArgument.Destroy;
@ -3987,12 +3938,95 @@ begin
ForEachChildCall(aMethodCall,Arg,EnumType,true);
end;
procedure TPasRecordType.ClearChildReferences(El: TPasElement; arg: pointer);
{ TPasMembersType }
procedure TPasMembersType.ClearChildReferences(El: TPasElement; arg: pointer);
begin
El.ClearTypeReferences(Self);
if arg=nil then ;
end;
procedure TPasMembersType.SetParent(const AValue: TPasElement);
begin
if (AValue=nil) and (Parent<>nil) then
begin
// parent is cleared
// -> clear all child references to this class/record (releasing loops)
ForEachCall(@ClearChildReferences,nil);
end;
inherited SetParent(AValue);
end;
constructor TPasMembersType.Create(const AName: string; AParent: TPasElement);
begin
inherited Create(AName, AParent);
PackMode:=pmNone;
Members := TFPList.Create;
GenericTemplateTypes:=TFPList.Create;
end;
destructor TPasMembersType.Destroy;
var
i: Integer;
El: TPasElement;
begin
for i := 0 to Members.Count - 1 do
begin
El:=TPasElement(Members[i]);
El.Parent:=nil;
El.Release{$IFDEF CheckPasTreeRefCount}('TPasMembersType.Members'){$ENDIF};
end;
FreeAndNil(Members);
for i := 0 to GenericTemplateTypes.Count - 1 do
begin
El:=TPasElement(GenericTemplateTypes[i]);
El.Parent:=nil;
El.Release{$IFDEF CheckPasTreeRefCount}('TPasMembersType.GenericTemplateTypes'){$ENDIF};
end;
FreeAndNil(GenericTemplateTypes);
inherited Destroy;
end;
function TPasMembersType.IsPacked: Boolean;
begin
Result:=(PackMode <> pmNone);
end;
function TPasMembersType.IsBitPacked: Boolean;
begin
Result:=(PackMode=pmBitPacked)
end;
procedure TPasMembersType.ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer);
var
i: Integer;
begin
inherited ForEachCall(aMethodCall, Arg);
for i:=0 to GenericTemplateTypes.Count-1 do
ForEachChildCall(aMethodCall,Arg,TPasElement(GenericTemplateTypes[i]),true);
for i:=0 to Members.Count-1 do
ForEachChildCall(aMethodCall,Arg,TPasElement(Members[i]),false);
end;
procedure TPasMembersType.SetGenericTemplates(AList: TFPList);
var
I: Integer;
El: TPasElement;
begin
For I:=0 to AList.Count-1 do
begin
El:=TPasElement(AList[i]);
El.Parent:=Self;
GenericTemplateTypes.Add(El);
end;
AList.Clear;
end;
{ TPasRecordType }
procedure TPasRecordType.GetMembers(S: TStrings);
Var
@ -4049,17 +4083,6 @@ begin
end;
end;
procedure TPasRecordType.SetParent(const AValue: TPasElement);
begin
if (AValue=nil) and (Parent<>nil) then
begin
// parent is cleared
// -> clear all child references to this class (releasing loops)
ForEachCall(@ClearChildReferences,nil);
end;
inherited SetParent(AValue);
end;
function TPasRecordType.GetDeclaration (full : boolean) : string;
Var
@ -4093,54 +4116,30 @@ var
i: Integer;
begin
inherited ForEachCall(aMethodCall, Arg);
for i:=0 to GenericTemplateTypes.Count-1 do
ForEachChildCall(aMethodCall,Arg,TPasElement(GenericTemplateTypes[i]),true);
for i:=0 to Members.Count-1 do
ForEachChildCall(aMethodCall,Arg,TPasElement(Members[i]),false);
ForEachChildCall(aMethodCall,Arg,VariantEl,true);
if Variants<>nil then
for i:=0 to Variants.Count-1 do
ForEachChildCall(aMethodCall,Arg,TPasElement(Variants[i]),false);
end;
function TPasRecordType.IsPacked: Boolean;
begin
Result:=(PackMode <> pmNone);
end;
function TPasRecordType.IsBitPacked: Boolean;
begin
Result:=(PackMode=pmBitPacked)
end;
function TPasRecordType.IsAdvancedRecord: Boolean;
Var
I : Integer;
Member: TPasElement;
begin
Result:=False;
I:=0;
While (Not Result) and (I<Members.Count) do
begin
Result:=TPasElement(Members[i]).InheritsFrom(TPasProcedureBase) or
TPasElement(Members[i]).InheritsFrom(TPasProperty);
Member:=TPasElement(Members[i]);
if (Member.Visibility<>visPublic) then exit(true);
if (Member.ClassType<>TPasVariable) then exit(true);
Inc(I);
end;
end;
procedure TPasRecordType.SetGenericTemplates(AList: TFPList);
var
I: Integer;
begin
For I:=0 to AList.Count-1 do
begin
TPasElement(AList[i]).Parent:=Self;
GenericTemplateTypes.Add(AList[i]);
end;
AList.Clear;
end;
procedure TPasProcedureType.GetArguments(List : TStrings);
Var

24
packages/fcl-passrc/src/pasuseanalyzer.pas
View File

@ -1479,6 +1479,25 @@ begin
begin
BuiltInProc:=TResElDataBuiltInProc(Decl.CustomData);
case BuiltInProc.BuiltIn of
bfExit:
begin
if El.Parent is TParamsExpr then
begin
Params:=(El.Parent as TParamsExpr).Params;
if length(Params)=1 then
begin
SubEl:=El.Parent;
while (SubEl<>nil) and not (SubEl is TPasProcedure) do
SubEl:=SubEl.Parent;
if (SubEl is TPasProcedure)
and (TPasProcedure(SubEl).ProcType is TPasFunctionType) then
begin
SubEl:=TPasFunctionType(TPasProcedure(SubEl).ProcType).ResultEl;
UseElement(SubEl,rraAssign,false);
end;
end;
end;
end;
bfTypeInfo:
begin
Params:=(El.Parent as TParamsExpr).Params;
@ -1490,9 +1509,10 @@ begin
{$ENDIF}
if ParamResolved.IdentEl=nil then
RaiseNotSupported(20180628155107,Params[0]);
if ParamResolved.IdentEl is TPasFunction then
if (ParamResolved.IdentEl is TPasProcedure)
and (TPasProcedure(ParamResolved.IdentEl).ProcType is TPasFunctionType) then
begin
SubEl:=TPasFunction(ParamResolved.IdentEl).FuncType.ResultEl.ResultType;
SubEl:=TPasFunctionType(TPasProcedure(ParamResolved.IdentEl).ProcType).ResultEl.ResultType;
MarkImplScopeRef(El,SubEl,psraTypeInfo);
UseTypeInfo(SubEl);
end

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

@ -81,7 +81,7 @@ const
nErrRecordConstantsNotAllowed = 2035;
nErrRecordMethodsNotAllowed = 2036;
nErrRecordPropertiesNotAllowed = 2037;
nErrRecordVisibilityNotAllowed = 2038;
// free , was nErrRecordVisibilityNotAllowed = 2038;
nParserTypeNotAllowedHere = 2039;
nParserNotAnOperand = 2040;
nParserArrayPropertiesCannotHaveDefaultValue = 2041;
@ -142,7 +142,7 @@ resourcestring
SErrRecordVariablesNotAllowed = 'Record variables not allowed at this location.';
SErrRecordMethodsNotAllowed = 'Record methods not allowed at this location.';
SErrRecordPropertiesNotAllowed = 'Record properties not allowed at this location.';
SErrRecordVisibilityNotAllowed = 'Record visibilities not allowed at this location.';
// free, was SErrRecordVisibilityNotAllowed = 'Record visibilities not allowed at this location.';
SParserTypeNotAllowedHere = 'Type "%s" not allowed here';
SParserNotAnOperand = 'Not an operand: (%d : %s)';
SParserArrayPropertiesCannotHaveDefaultValue = 'Array properties cannot have default value';
@ -4504,7 +4504,7 @@ begin
ParseVarList(Parent,List,AVisibility,False);
tt:=[tkEnd,tkSemicolon];
if ClosingBrace then
include(tt,tkBraceClose);
Include(tt,tkBraceClose);
if not (CurToken in tt) then
ParseExc(nParserExpectedSemiColonEnd,SParserExpectedSemiColonEnd);
end;
@ -6362,15 +6362,13 @@ begin
tkGeneric, // Counts as field name
tkIdentifier :
begin
if CheckVisibility(CurtokenString,v) then
begin
If not (msAdvancedRecords in Scanner.CurrentModeSwitches) then
ParseExc(nErrRecordVisibilityNotAllowed,SErrRecordVisibilityNotAllowed);
if not (v in [visPrivate,visPublic,visStrictPrivate]) then
ParseExc(nParserInvalidRecordVisibility,SParserInvalidRecordVisibility);
NextToken;
Continue;
end;
If AllowMethods and CheckVisibility(CurTokenString,v) then
begin
if not (v in [visPrivate,visPublic,visStrictPrivate]) then
ParseExc(nParserInvalidRecordVisibility,SParserInvalidRecordVisibility);
NextToken;
Continue;
end;
OldCount:=ARec.Members.Count;
ParseInlineVarDecl(ARec, ARec.Members, v, AEndToken=tkBraceClose);
for i:=OldCount to ARec.Members.Count-1 do
@ -6423,12 +6421,15 @@ begin
try
Result.PackMode:=PackMode;
NextToken;
ParseRecordFieldList(Result,tkEnd,true);
ParseRecordFieldList(Result,tkEnd,msAdvancedRecords in Scanner.CurrentModeSwitches);
Engine.FinishScope(stTypeDef,Result);
ok:=true;
finally
if not ok then
begin
Result.Parent:=nil; // clear references from members to Result
Result.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
end;
end;
end;
@ -6826,7 +6827,8 @@ begin
end;
exit;
end;
if ((AobjKind in [okClass,OKInterface]) and (msExternalClass in CurrentModeswitches) and CurTokenIsIdentifier('external')) then
if ((AObjKind in [okClass,OKInterface]) and (msExternalClass in CurrentModeswitches)
and CurTokenIsIdentifier('external')) then
begin
NextToken;
if CurToken<>tkString then

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

@ -483,7 +483,27 @@ type
Procedure TestRecord_Const_UntypedFail;
Procedure TestRecord_Const_NestedRecord;
Procedure TestRecord_Const_Variant;
Procedure TestRecord_VarExternal; // ToDo
Procedure TestRecord_VarExternal;
Procedure TestRecord_VarSelfFail;
// advanced record
Procedure TestAdvRecord;
Procedure TestAdvRecord_Private; // ToDo
// Todo: Procedure TestAdvRecord_ForwardFail
// ToDo: public, private, strict private
// ToDo: TestAdvRecordPublsihedFail
// ToDo: TestAdvRecord_VirtualFail
// ToDo: TestAdvRecord_OverrideFail
// ToDo: constructor, destructor
// ToDo: class function/procedure
// ToDo: nested record type
// ToDo: const
// todo: var
// todo: class var
// todo: property
// todo: class property
// todo: TestRecordAsFuncResult
// todo: for in record
// class
Procedure TestClass;
@ -1579,7 +1599,7 @@ begin
if (Msg<>E.Message) and (Msg<>E.MsgPattern) and (Msg<>Full) then
begin
{$IFDEF VerbosePasResolver}
writeln('TCustomTestResolver.CheckResolverException E.MsgPattern={',E.MsgPattern,'}');
writeln('TCustomTestResolver.CheckResolverException E.MsgPattern={',E.MsgPattern,'} E.Message={',E.Message,'} Full={',Full,'}');
{$ENDIF}
AssertEquals('Expected message ('+IntToStr(MsgNumber)+')',
'{'+Msg+'}','{'+E.Message+'} OR {'+E.MsgPattern+'} OR {'+Full+'}');
@ -7787,6 +7807,55 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestRecord_VarSelfFail;
begin
StartProgram(false);
Add([
'type',
' TRec = record',
' r: Trec;',
' end;',
'begin']);
CheckResolverException('type "TRec" is not yet completely defined',nTypeXIsNotYetCompletelyDefined);
end;
procedure TTestResolver.TestAdvRecord;
begin
StartProgram(false);
Add([
'{$modeswitch advancedrecords}',
'type',
' TRec = record',
' procedure DoIt;',
' end;',
'procedure TRec.DoIt;',
'begin',
'end;',
'begin']);
ParseProgram;
end;
procedure TTestResolver.TestAdvRecord_Private;
begin
exit;
StartProgram(false);
Add([
'{$modeswitch advancedrecords}',
'type',
' TRec = record',
' private',
' a: byte;',
' public',
' b: byte;',
' end;',
'var',
' r: TRec;',
'begin',
' r.a:=r.b;']);
ParseProgram;
end;
procedure TTestResolver.TestClass;
begin
StartProgram(false);

3
packages/fcl-passrc/tests/tctypeparser.pas
View File

@ -2043,6 +2043,7 @@ Var
P : TPasFunction;
begin
Scanner.CurrentModeSwitches:=Scanner.CurrentModeSwitches+[msAdvancedRecords];
TestFields(['x : integer;','class operator assign(a : ta; b : Cardinal) : boolean;','function dosomething3 : Integer;'],'',False);
AssertEquals('Member count',3,TheRecord.Members.Count);
AssertField1([]);
@ -2057,6 +2058,7 @@ end;
procedure TTestRecordTypeParser.TestFieldAndClassVar;
begin
Scanner.CurrentModeSwitches:=Scanner.CurrentModeSwitches+[msAdvancedRecords];
TestFields(['x : integer;','class var y : integer;'],'',False);
AssertField1([]);
AssertTrue('Second field is class var',vmClass in Field2.VarModifiers);
@ -2064,6 +2066,7 @@ end;
procedure TTestRecordTypeParser.TestFieldAndVar;
begin
Scanner.CurrentModeSwitches:=Scanner.CurrentModeSwitches+[msAdvancedRecords];
TestFields(['x : integer;','var y : integer;'],'',False);
AssertField1([]);
AssertTrue('Second field is regular var',not (vmClass in Field2.VarModifiers));

15
packages/fcl-passrc/tests/tcuseanalyzer.pas
View File

@ -128,6 +128,7 @@ type
procedure TestM_Hint_FunctionResultRecord;
procedure TestM_Hint_FunctionResultPassRecordElement;
procedure TestM_Hint_FunctionResultAssembler;
procedure TestM_Hint_FunctionResultExit;
procedure TestM_Hint_AbsoluteVar;
// whole program optimization
@ -2158,6 +2159,20 @@ begin
CheckUseAnalyzerUnexpectedHints;
end;
procedure TTestUseAnalyzer.TestM_Hint_FunctionResultExit;
begin
StartProgram(false);
Add([
'function GetIt: longint;',
'begin',
' exit(3);',
'end;',
'begin',
' GetIt;']);
AnalyzeProgram;
CheckUseAnalyzerUnexpectedHints;
end;
procedure TTestUseAnalyzer.TestM_Hint_AbsoluteVar;
begin
StartProgram(false);