From 18f670a822005637ab96a1cad54866af27f4a48a Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Wed, 23 Jan 2019 22:58:11 +0000 Subject: [PATCH] fcl-passrc: parse and resolve helpers git-svn-id: trunk@41022 - --- packages/fcl-passrc/src/pasresolveeval.pas | 8 +- packages/fcl-passrc/src/pasresolver.pp | 1893 +++++++++++++------- packages/fcl-passrc/src/pastree.pp | 30 +- packages/fcl-passrc/src/pasuseanalyzer.pas | 2 +- packages/fcl-passrc/src/pparser.pp | 62 +- packages/fcl-passrc/src/pscanner.pp | 10 +- packages/fcl-passrc/tests/tcgenerics.pp | 114 +- packages/fcl-passrc/tests/tcprocfunc.pas | 6 +- packages/fcl-passrc/tests/tcresolver.pas | 680 ++++++- 9 files changed, 2087 insertions(+), 718 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolveeval.pas b/packages/fcl-passrc/src/pasresolveeval.pas index 5c8b324b34..96656fa33a 100644 --- a/packages/fcl-passrc/src/pasresolveeval.pas +++ b/packages/fcl-passrc/src/pasresolveeval.pas @@ -119,7 +119,7 @@ const nWrongNumberOfParametersForArray = 3042; nCantAssignValuesToAnAddress = 3043; nIllegalExpression = 3044; - nCantAccessPrivateMember = 3045; + nCantAccessXMember = 3045; nMustBeInsideALoop = 3046; nExpectXArrayElementsButFoundY = 3047; nCannotCreateADescendantOfTheSealedXY = 3048; @@ -178,6 +178,8 @@ const nFunctionHidesIdentifier_NonProc = 3112; nTypeXCannotBeExtendedByATypeHelper = 3113; nDerivedXMustExtendASubClassY = 3114; + nDefaultPropertyNotAllowedInHelperForX = 3115; + nHelpersCannotBeUsedAsTypes = 3116; // using same IDs as FPC nVirtualMethodXHasLowerVisibility = 3250; // was 3050 @@ -236,7 +238,7 @@ resourcestring sWrongNumberOfParametersForArray = 'Wrong number of parameters for array'; sCantAssignValuesToAnAddress = 'Can''t assign values to an address'; sIllegalExpression = 'Illegal expression'; - sCantAccessPrivateMember = 'Can''t access %s member %s'; + sCantAccessXMember = 'Can''t access %s member %s'; sMustBeInsideALoop = '%s must be inside a loop'; sExpectXArrayElementsButFoundY = 'Expect %s array elements, but found %s'; sCannotCreateADescendantOfTheSealedXY = 'Cannot create a descendant of the sealed %s "%s"'; @@ -303,6 +305,8 @@ resourcestring 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'; + sDefaultPropertyNotAllowedInHelperForX = 'Default property not allowed in helper for %s'; + sHelpersCannotBeUsedAsTypes = 'helpers cannot be used as types'; type { TResolveData - base class for data stored in TPasElement.CustomData } diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 250674dec2..fcbc4b2766 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -228,6 +228,17 @@ Works: - with - self - built-in procedure Val(const s: string; var e: enumtype; out Code: integertype); +- helpers: + - class + - record + - type helper for simple type variables + - InterfaceHelpers for fast gathering of helpers from uses sections + - "inherited" and "inherited name" for Delphi and ObjFPC + - for i in typehelped + - nested: type, const, class var + - visibility + - property + - helper method, Self as var argument ToDo: - operator overload @@ -694,9 +705,8 @@ type TPasScope = Class(TResolveData) public - VisibilityContext: TPasElement; // methods sets this to a TPasClassType, - // used to check if the current context is allowed to access a - // private/protected element + VisibilityContext: TPasElement; // used to check if the current context + // is allowed to access a private/protected element class function IsStoredInElement: boolean; virtual; class function FreeOnPop: boolean; virtual; procedure IterateElements(const aName: string; StartScope: TPasScope; @@ -705,6 +715,7 @@ type procedure WriteIdentifiers(Prefix: string); virtual; end; TPasScopeClass = class of TPasScope; + TPasScopeArray = array of TPasScope; TPasModuleScopeFlag = ( pmsfAssertSearched, // assert constructors searched @@ -802,6 +813,7 @@ type procedure WriteLocalIdentifiers(Prefix: string); virtual; function GetLocalIdentifiers: TFPList; virtual; end; + TPasIdentifierScopeArray = array of TPasIdentifierScope; { TPasDefaultScope - root scope } @@ -810,6 +822,24 @@ type class function IsStoredInElement: boolean; override; end; + { TPasIterateFilterData } + + TPasIterateFilterData = record + OnIterate: TIterateScopeElement; + Data: Pointer; + end; + PPasIterateFilterData = ^TPasIterateFilterData; + + { TPRHelperEntry } + + TPRHelperEntry = class + public + Added: integer; // Added is bigger when it was added later to the list + HelperForType: TPasType; // alias resolved + Helper: TPasClassType; + end; + TPRHelperEntryArray = array of TPRHelperEntry; + { TPasSectionScope - e.g. interface, implementation, program, library } TPasSectionScope = Class(TPasIdentifierScope) @@ -822,6 +852,7 @@ type Finished: boolean; BoolSwitches: TBoolSwitches; ModeSwitches: TModeSwitches; + Helpers: TPRHelperEntryArray; // only created for interface. Sorted ascending ComparePRHelperEntries constructor Create; override; destructor Destroy; override; function FindIdentifier(const Identifier: String): TPasIdentifier; override; @@ -889,18 +920,31 @@ type AncestorScope: TPasClassScope; CanonicalClassOf: TPasClassOfType; DirectAncestor: TPasType; // TPasClassType or TPasAliasType, see GetPasClassAncestor + // Note: TPasClassType.AncestorType might be nil and DirectAncestor is "TObject" Flags: TPasClassScopeFlags; AbstractProcs: TArrayOfPasProcedure; Interfaces: TFPList; // list corresponds to TPasClassType(Element).Interfaces, // elements: TPasProperty for 'implements', or TPasClassIntfMap destructor Destroy; override; + end; + TPasClassScopeClass = class of TPasClassScope; + + { TPasGroupScope } + + TPasGroupScope = Class(TPasIdentifierScope) + public + Scopes: TPasIdentifierScopeArray; + Count: integer; + procedure Add(Scope: TPasIdentifierScope); + destructor Destroy; override; + function GetFirstNonHelperScope: TPasIdentifierScope; + class function IsStoredInElement: boolean; override; function FindIdentifier(const Identifier: String): TPasIdentifier; override; procedure IterateElements(const aName: string; StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); override; procedure WriteIdentifiers(Prefix: string); override; end; - TPasClassScopeClass = class of TPasClassScope; TPasProcedureScopeFlag = ( ppsfIsGroupOverload // mode objfpc: one overload is enough for all procs in same scope @@ -914,7 +958,8 @@ 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) - ClassOrRecordScope: TPasClassOrRecordScope; + ClassRecScope: TPasClassOrRecordScope; + GroupScope: TPasGroupScope; // set during parsing a method body SelfArg: TPasArgument; Flags: TPasProcedureScopeFlags; BoolSwitches: TBoolSwitches; // if Body<>nil then body start, otherwise when FinishProc @@ -964,7 +1009,8 @@ type WithScope: TPasWithScope; // owner Index: integer; Expr: TPasExpr; - Scope: TPasScope; + Scope: TPasGroupScope; + ClassRecScope: TPasClassOrRecordScope; Flags: TPasWithExprScopeFlags; class function IsStoredInElement: boolean; override; class function FreeOnPop: boolean; override; @@ -972,6 +1018,7 @@ type const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); override; procedure WriteIdentifiers(Prefix: string); override; + destructor Destroy; override; end; TPasWithExprScopeClass = class of TPasWithExprScope; @@ -1001,14 +1048,6 @@ type class function IsStoredInElement: boolean; override; end; - { TPasIterateFilterData } - - TPasIterateFilterData = record - OnIterate: TIterateScopeElement; - Data: Pointer; - end; - PPasIterateFilterData = ^TPasIterateFilterData; - { TPasModuleDotScope - scope for searching unitname. } TPasModuleDotScope = Class(TPasSubExprScope) @@ -1030,11 +1069,11 @@ type property Module: TPasModule read FModule write SetModule; end; - { TPasDotIdentifierScope } + { TPasDotBaseScope } - TPasDotIdentifierScope = Class(TPasSubExprScope) + TPasDotBaseScope = Class(TPasSubExprScope) public - IdentifierScope: TPasIdentifierScope; + GroupScope: TPasGroupScope; OnlyTypeMembers: boolean; // true=only class var/procs, false=default=all ConstParent: boolean; function FindIdentifier(const Identifier: String): TPasIdentifier; override; @@ -1042,47 +1081,55 @@ type const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); override; procedure WriteIdentifiers(Prefix: string); override; + destructor Destroy; override; end; { TPasDotEnumTypeScope - used for EnumType.EnumValue } - TPasDotEnumTypeScope = Class(TPasDotIdentifierScope) + TPasDotEnumTypeScope = Class(TPasDotBaseScope) + public + EnumScope: TPasEnumTypeScope; + function FindIdentifier(const Identifier: String): TPasIdentifier; override; + procedure IterateElements(const aName: string; StartScope: TPasScope; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); override; + procedure WriteIdentifiers(Prefix: string); override; end; { TPasDotClassOrRecordScope } - TPasDotClassOrRecordScope = Class(TPasDotIdentifierScope) - end; - - { TPasDotRecordScope - used for aRecord.subidentifier } - - TPasDotRecordScope = Class(TPasDotClassOrRecordScope) - private - function GetRecordScope: TPasRecordScope; + TPasDotClassOrRecordScope = Class(TPasDotBaseScope) public - property RecordScope: TPasRecordScope read GetRecordScope; + ClassRecScope: TPasClassOrRecordScope; end; { TPasDotClassScope - used for aClass.subidentifier } TPasDotClassScope = Class(TPasDotClassOrRecordScope) - private - FClassScope: TPasClassScope; - procedure SetClassScope(AValue: TPasClassScope); public - InheritedExpr: boolean; // this is 'inherited ' instead of '.HelperForType2.PasElementId then + exit(-1) + {$ELSE} + if Pointer(HelperForType1)>Pointer(HelperForType2) then + exit(1) + else if Pointer(HelperForType1)nil then exit; + aClassScope:=AncestorScope; + while aClassScope<>nil do + begin + Result:=aClassScope.FindIdentifier(Identifier); + if Result<>nil then exit; + aClassScope:=aClassScope.AncestorScope; + end; +end; + +procedure TPasInheritedScope.IterateElements(const aName: string; + StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; + Data: Pointer; var Abort: boolean); +var + aClassScope: TPasClassScope; +begin + inherited IterateElements(aName, StartScope, OnIterateElement, Data, Abort); + if Abort then exit; + aClassScope:=AncestorScope; + while aClassScope<>nil do + begin + aClassScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort); + if Abort then exit; + aClassScope:=aClassScope.AncestorScope; + end; +end; + +procedure TPasInheritedScope.WriteIdentifiers(Prefix: string); +var + aClassScope: TPasClassScope; +begin + inherited WriteIdentifiers(Prefix); + aClassScope:=AncestorScope; + while aClassScope<>nil do + begin + aClassScope.WriteIdentifiers(Prefix); + aClassScope:=aClassScope.AncestorScope; + end; +end; + +{ TPasDotEnumTypeScope } + +function TPasDotEnumTypeScope.FindIdentifier(const Identifier: String + ): TPasIdentifier; +begin + Result:=EnumScope.FindLocalIdentifier(Identifier); + if Result<>nil then exit; + Result:=inherited FindIdentifier(Identifier); +end; + +procedure TPasDotEnumTypeScope.IterateElements(const aName: string; + StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; + Data: Pointer; var Abort: boolean); +begin + EnumScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort); + if Abort then exit; + inherited IterateElements(aName, StartScope, OnIterateElement, Data, Abort); +end; + +procedure TPasDotEnumTypeScope.WriteIdentifiers(Prefix: string); +begin + EnumScope.WriteIdentifiers(Prefix); + inherited WriteIdentifiers(Prefix); +end; + +{ TPasGroupScope } + +procedure TPasGroupScope.Add(Scope: TPasIdentifierScope); +var + i: Integer; +begin + for i:=0 to Count-1 do + if Scopes[i]=Scope then exit; // already added + if Scope.FreeOnPop then + raise Exception.Create('TPasGroupScope.Add '+GetObjName(Scope)+' '+GetObjName(Scope.Element)); + if Count=length(Scopes) then + SetLength(Scopes,Count*2+4); + Scopes[Count]:=Scope; + inc(Count); +end; + +destructor TPasGroupScope.Destroy; +begin + Scopes:=nil; + Count:=0; + inherited Destroy; +end; + +function TPasGroupScope.GetFirstNonHelperScope: TPasIdentifierScope; +var + i: Integer; + Scope: TPasIdentifierScope; +begin + for i:=0 to Count-1 do + begin + Scope:=Scopes[i]; + if (Scope.ClassType<>TPasClassScope) + or (TPasClassType(Scope.Element).HelperForType=nil) then + exit(Scope); + end; + Result:=nil; +end; + +class function TPasGroupScope.IsStoredInElement: boolean; +begin + Result:=false; +end; + +function TPasGroupScope.FindIdentifier(const Identifier: String + ): TPasIdentifier; +var + i: Integer; +begin + for i:=0 to Count-1 do + begin + Result:=Scopes[i].FindIdentifier(Identifier); + if Result<>nil then exit; + end; + Result:=nil; +end; + +procedure TPasGroupScope.IterateElements(const aName: string; + StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; + Data: Pointer; var Abort: boolean); +var + i: Integer; +begin + for i:=0 to Count-1 do + begin + Scopes[i].IterateElements(aName,StartScope,OnIterateElement,Data,Abort); + if Abort then exit; + end; +end; + +procedure TPasGroupScope.WriteIdentifiers(Prefix: string); +var + i: Integer; +begin + for i:=0 to Count-1 do + Scopes[i].WriteIdentifiers(Prefix+'Group['+IntToStr(i)+'/'+IntToStr(Count)+']'); +end; + {$ifdef pas2js} { TPasResHashList } @@ -2903,24 +3154,30 @@ begin {$ENDIF} end; -{ TPasDotIdentifierScope } +{ TPasDotBaseScope } -function TPasDotIdentifierScope.FindIdentifier(const Identifier: String +function TPasDotBaseScope.FindIdentifier(const Identifier: String ): TPasIdentifier; begin - Result:=IdentifierScope.FindIdentifier(Identifier); + Result:=GroupScope.FindIdentifier(Identifier); end; -procedure TPasDotIdentifierScope.IterateElements(const aName: string; +procedure TPasDotBaseScope.IterateElements(const aName: string; StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); begin - IdentifierScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort); + GroupScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort); end; -procedure TPasDotIdentifierScope.WriteIdentifiers(Prefix: string); +procedure TPasDotBaseScope.WriteIdentifiers(Prefix: string); begin - IdentifierScope.WriteIdentifiers(Prefix); + GroupScope.WriteIdentifiers(Prefix); +end; + +destructor TPasDotBaseScope.Destroy; +begin + FreeAndNil(GroupScope); + inherited Destroy; end; { TPasWithExprScope } @@ -2950,6 +3207,12 @@ begin {AllowWriteln-} end; +destructor TPasWithExprScope.Destroy; +begin + FreeAndNil(Scope); + inherited Destroy; +end; + { TPasWithScope } constructor TPasWithScope.Create; @@ -2974,51 +3237,20 @@ end; function TPasProcedureScope.FindIdentifier(const Identifier: String ): TPasIdentifier; -var - CurScope: TPasIdentifierScope; - ParentEl: TPasElement; begin Result:=inherited FindIdentifier(Identifier); - if Result<>nil then exit; - CurScope:=ClassOrRecordScope; - if CurScope=nil then exit; - repeat - Result:=CurScope.FindIdentifier(Identifier); - if Result<>nil then exit; - ParentEl:=CurScope.Element.Parent; - if ParentEl=nil then exit; - if (ParentEl.ClassType=TPasClassType) then - CurScope:=TPasClassScope(ParentEl.CustomData) - else if (ParentEl.ClassType=TPasRecordType) then - CurScope:=TPasRecordScope(ParentEl.CustomData) - else - exit; - until false; + if (Result<>nil) or (GroupScope=nil) then exit; + Result:=GroupScope.FindIdentifier(Identifier); end; procedure TPasProcedureScope.IterateElements(const aName: string; StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); -var - CurScope: TPasIdentifierScope; - ParentEl: TPasElement; begin inherited IterateElements(aName, StartScope, OnIterateElement, Data, Abort); if Abort then exit; - CurScope:=ClassOrRecordScope; - if CurScope=nil then exit; - repeat - CurScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort); - if Abort then exit; - ParentEl:=CurScope.Element.Parent; - if ParentEl=nil then exit; - if (ParentEl.ClassType=TPasClassType) then - CurScope:=TPasClassScope(ParentEl.CustomData) - else if (ParentEl.ClassType=TPasRecordType) then - CurScope:=TPasRecordScope(ParentEl.CustomData) - else - exit; - until false; + if GroupScope=nil then exit; + GroupScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort); end; function TPasProcedureScope.GetSelfScope: TPasProcedureScope; @@ -3027,7 +3259,7 @@ var begin Result:=Self; repeat - if Result.ClassOrRecordScope<>nil then exit; + if Result.ClassRecScope<>nil then exit; Proc:=TPasProcedure(Element); if not (Proc.Parent is TProcedureBody) then exit(nil); Proc:=Proc.Parent.Parent as TPasProcedure; @@ -3038,16 +3270,17 @@ end; procedure TPasProcedureScope.WriteIdentifiers(Prefix: string); begin inherited WriteIdentifiers(Prefix); - if ClassOrRecordScope<>nil then - ClassOrRecordScope.WriteIdentifiers(Prefix+'CS '); + if GroupScope<>nil then + GroupScope.WriteIdentifiers(Prefix+'GS '); end; destructor TPasProcedureScope.Destroy; begin - FreeAndNil(References); {$IFDEF VerbosePasResolverMem} writeln('TPasProcedureScope.Destroy START ',ClassName); {$ENDIF} + FreeAndNil(References); + FreeAndNil(GroupScope); inherited Destroy; ReleaseAndNil(TPasElement(SelfArg){$IFDEF CheckPasTreeRefCount},'TPasProcedureScope.SelfArg'{$ENDIF}); {$IFDEF VerbosePasResolverMem} @@ -3100,48 +3333,6 @@ begin inherited Destroy; end; -function TPasClassScope.FindIdentifier(const Identifier: String - ): TPasIdentifier; -begin - Result:=inherited FindIdentifier(Identifier); - if Result<>nil then exit; - if AncestorScope<>nil then - Result:=AncestorScope.FindIdentifier(Identifier); -end; - -procedure TPasClassScope.IterateElements(const aName: string; - StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; - Data: Pointer; var Abort: boolean); -begin - inherited IterateElements(aName, StartScope, OnIterateElement, Data, Abort); - if Abort then exit; - if AncestorScope<>nil then - AncestorScope.IterateElements(aName,StartScope,OnIterateElement,Data,Abort); -end; - -procedure TPasClassScope.WriteIdentifiers(Prefix: string); -begin - inherited WriteIdentifiers(Prefix); - if AncestorScope<>nil then - AncestorScope.WriteIdentifiers(Prefix+'AS '); -end; - -{ TPasDotRecordScope } - -function TPasDotRecordScope.GetRecordScope: TPasRecordScope; -begin - Result:=TPasRecordScope(IdentifierScope); -end; - -{ TPasDotClassScope } - -procedure TPasDotClassScope.SetClassScope(AValue: TPasClassScope); -begin - if FClassScope=AValue then Exit; - FClassScope:=AValue; - IdentifierScope:=AValue; -end; - { TPasIdentifier } procedure TPasIdentifier.SetElement(AValue: TPasElement); @@ -3335,6 +3526,7 @@ begin {$IFDEF VerbosePasResolverMem} writeln('TPasSectionScope.Destroy START ',ClassName); {$ENDIF} + ClearHelperList(Helpers); FreeAndNil(UsesScopes); inherited Destroy; {$IFDEF VerbosePasResolverMem} @@ -4063,7 +4255,7 @@ begin FRootElement:=AValue; end; -procedure TPasResolver.OnFindFirstElement(El: TPasElement; ElScope, +procedure TPasResolver.OnFindFirst_PreferNoParams(El: TPasElement; ElScope, StartScope: TPasScope; FindFirstElementData: Pointer; var Abort: boolean); var Data: PPRFindData absolute FindFirstElementData; @@ -4085,6 +4277,17 @@ begin Abort:=true; end; +procedure TPasResolver.OnFindFirst(El: TPasElement; ElScope, + StartScope: TPasScope; FindFirstElementData: Pointer; var Abort: boolean); +var + Data: PPRFindData absolute FindFirstElementData; +begin + Data^.Found:=El; + Data^.ElScope:=ElScope; + Data^.StartScope:=StartScope; + Abort:=true; +end; + procedure TPasResolver.OnFindCallElements(El: TPasElement; ElScope, StartScope: TPasScope; FindProcsData: Pointer; var Abort: boolean); var @@ -4377,10 +4580,10 @@ begin end; end; -procedure TPasResolver.OnFindOverloadProc(El: TPasElement; ElScope, - StartScope: TPasScope; FindOverloadData: Pointer; var Abort: boolean); +procedure TPasResolver.OnFindProc(El: TPasElement; ElScope, + StartScope: TPasScope; FindProcData: Pointer; var Abort: boolean); var - Data: PFindOverloadProcData absolute FindOverloadData; + Data: PFindProcData absolute FindProcData; Proc: TPasProcedure; Store, SameScope: Boolean; ProcScope: TPasProcedureScope; @@ -4393,7 +4596,7 @@ var end; begin - //writeln('TPasResolver.OnFindOverloadProc START ',El.Name,':',GetElementTypeName(El),' itself=',El=Data^.Proc); + //writeln('TPasResolver.OnFindProcSameSignature START ',El.Name,':',GetElementTypeName(El),' itself=',El=Data^.Proc); if not (El is TPasProcedure) then begin // identifier is not a proc @@ -4414,7 +4617,7 @@ begin exit; // no hint end; case Data^.Kind of - fopkProc: + fpkProc: // proc hides a non proc if (Data^.Proc.GetModule=El.GetModule) then // forbidden within same module @@ -4427,7 +4630,7 @@ begin LogMsg(20171118205344,mtHint,nFunctionHidesIdentifier_NonProc,sFunctionHidesIdentifier, [GetElementSourcePosStr(El)],Data^.Proc.ProcType); end; - fopkMethod: + fpkMethod: // method hides a non proc RaiseMsg(20171118232543,nDuplicateIdentifier,sDuplicateIdentifier, [El.Name,GetElementSourcePosStr(El)],Data^.Proc.ProcType); @@ -4444,24 +4647,15 @@ begin exit; end; - //writeln('TPasResolver.OnFindOverloadProc Data^.OnlyScope=',GetObjName(Data^.OnlyScope),' ElScope=',GetObjName(ElScope),' Same=',Data^.OnlyScope=ElScope); - if (Data^.OnlyScope<>nil) and (Data^.OnlyScope<>ElScope) then - begin - // do not search any further, only one scope should be searched - // for example when searching the method declaration of a method body - Abort:=false; - exit; - end; - {$IFDEF VerbosePasResolver} - writeln('TPasResolver.OnFindOverloadProc ',GetTreeDbg(El,2)); + writeln('TPasResolver.OnFindProcSameSignature ',GetTreeDbg(El,2)); {$ENDIF} Store:=CheckOverloadProcCompatibility(Data^.Proc,Proc); - if Data^.Kind=fopkSameSignature then + if Data^.Kind=fpkSameSignature then // finding a proc with same signature is enough, see above Data^.OnlyScope else begin - if Data^.Kind=fopkProc then + if Data^.Kind=fpkProc then SameScope:=Data^.Proc.GetModule=Proc.GetModule else SameScope:=Data^.Proc.Parent=Proc.Parent; @@ -4513,7 +4707,7 @@ begin or ((Data^.FoundInSameScope=1) // missing 'overload' hints only for the first proc in a scope and not ProcHasGroupOverload(Data^.Proc)) then begin - if (Data^.Kind=fopkMethod) and (Proc.IsVirtual or Proc.IsOverride) then + if (Data^.Kind=fpkMethod) and (Proc.IsVirtual or Proc.IsOverride) then // give a hint, that method hides a virtual method in ancestor LogMsg(20170216151712,mtWarning,nMethodHidesMethodOfBaseType, sMethodHidesMethodOfBaseType, @@ -4573,19 +4767,18 @@ begin Result:=false; end; -function TPasResolver.FindProcOverload(const ProcName: string; - Proc: TPasProcedure; OnlyScope: TPasScope): TPasProcedure; +function TPasResolver.FindProcSameSignature(const ProcName: string; + Proc: TPasProcedure; Scope: TPasScope): TPasProcedure; var - FindData: TFindOverloadProcData; + FindData: TFindProcData; Abort: boolean; begin - FindData:=Default(TFindOverloadProcData); + FindData:=Default(TFindProcData); FindData.Proc:=Proc; FindData.Args:=Proc.ProcType.Args; - FindData.Kind:=fopkSameSignature; - FindData.OnlyScope:=OnlyScope; + FindData.Kind:=fpkSameSignature; Abort:=false; - OnlyScope.IterateElements(ProcName,OnlyScope,@OnFindOverloadProc,@FindData,Abort); + Scope.IterateElements(ProcName,Scope,@OnFindProc,@FindData,Abort); Result:=FindData.Found; end; @@ -4632,15 +4825,21 @@ function TPasResolver.AddIdentifier(Scope: TPasIdentifierScope; const aName: String; El: TPasElement; const Kind: TPasIdentifierKind ): TPasIdentifier; var + Group: TPasGroupScope; Identifier, OlderIdentifier: TPasIdentifier; - ClassScope: TPasClassScope; OlderEl: TPasElement; - IsClassScope: Boolean; C: TClass; + i: Integer; + OtherScope: TPasIdentifierScope; begin if aName='' then exit(nil); - - IsClassScope:=(Scope is TPasClassScope); + if Scope is TPasGroupScope then + begin + Group:=TPasGroupScope(Scope); + Scope:=Group.Scopes[0]; + end + else + Group:=nil; if (El.Visibility=visPublished) then begin @@ -4653,14 +4852,13 @@ begin RaiseMsg(20170403223024,nSymbolCannotBePublished,sSymbolCannotBePublished,[],El); end; - if (Kind=pikSimple) and IsClassScope - and (El.ClassType<>TPasProperty) then + if (Kind=pikSimple) and (Group<>nil) and (El.ClassType<>TPasProperty) then begin - // check duplicate in ancestors - ClassScope:=TPasClassScope(Scope).AncestorScope; - while ClassScope<>nil do + // check duplicate in ancestors and helpers + for i:=1 to Group.Count-1 do begin - OlderIdentifier:=ClassScope.FindLocalIdentifier(aName); + OtherScope:=Group.Scopes[i]; + OlderIdentifier:=OtherScope.FindLocalIdentifier(aName); while OlderIdentifier<>nil do begin OlderEl:=OlderIdentifier.Element; @@ -4676,7 +4874,6 @@ begin RaiseMsg(20170221130001,nDuplicateIdentifier,sDuplicateIdentifier, [aName,GetElementSourcePosStr(OlderEl)],El); end; - ClassScope:=ClassScope.AncestorScope; end; end; @@ -4779,11 +4976,12 @@ var i, j: Integer; PublicEl, UseModule: TPasElement; Scope: TPasSectionScope; - UsesScope: TPasIdentifierScope; + UsesScope: TPasSectionScope; UseUnit: TPasUsesUnit; FirstName: String; p: SizeInt; OldIdentifier: TPasIdentifier; + IntfHelpers: TPRHelperEntryArray; begin CheckTopScope(ScopeClass_Section); Scope:=TPasSectionScope(TopScope); @@ -4816,9 +5014,10 @@ begin if PublicEl.CustomData=nil then RaiseInternalError(20160922163358,'uses element has no resolver data: ' +UseUnit.Name+'->'+GetObjName(PublicEl)); - if not (PublicEl.CustomData is TPasIdentifierScope) then + if not (PublicEl.CustomData is TPasSectionScope) then RaiseInternalError(20160922163403,'uses element has invalid resolver data: ' +UseUnit.Name+'->'+GetObjName(PublicEl)+'->'+PublicEl.CustomData.ClassName); + UsesScope:=TPasSectionScope(PublicEl.CustomData); // check if module was already used by a different name j:=i; @@ -4843,12 +5042,16 @@ begin AddIdentifier(Scope,UseUnit.Name,UseUnit,pikSimple); // add scope - UsesScope:=TPasIdentifierScope(PublicEl.CustomData); {$IFDEF VerbosePasResolver} writeln('TPasResolver.FinishUsesClause Add UsesScope=',GetObjName(UsesScope)); {$ENDIF} Scope.UsesScopes.Add(UsesScope); + // add helpers + IntfHelpers:=UsesScope.Helpers; + for j:=0 to length(IntfHelpers)-1 do + AddActiveHelper(TPRHelperEntry(IntfHelpers[j]).Helper); + EmitElementHints(Section,UseUnit); end; @@ -4894,31 +5097,40 @@ begin end; procedure TPasResolver.FinishTypeSection(El: TPasElement); +begin + // resolve pending forwards + if El is TPasDeclarations then + FinishDeclarations(TPasDeclarations(El)) + else if El is TPasMembersType then + FinishMemberType(TPasMembersType(El)) + else + RaiseNotYetImplemented(20181226105933,El); +end; + +procedure TPasResolver.FinishDeclarations(El: TPasDeclarations); var i: Integer; Decl: TPasElement; begin - // resolve pending forwards - if El is TPasDeclarations then + for i:=0 to El.Declarations.Count-1 do begin - for i:=0 to TPasDeclarations(El).Declarations.Count-1 do - begin - Decl:=TPasElement(TPasDeclarations(El).Declarations[i]); - if Decl is TPasType then - FinishTypeSectionEl(TPasType(Decl)); - end; - end - else if El is TPasMembersType then + Decl:=TPasElement(El.Declarations[i]); + if Decl is TPasType then + FinishTypeSectionEl(TPasType(Decl)); + end; +end; + +procedure TPasResolver.FinishMemberType(El: TPasMembersType); +var + i: Integer; + Decl: TPasElement; +begin + for i:=0 to El.Members.Count-1 do begin - for i:=0 to TPasMembersType(El).Members.Count-1 do - begin - Decl:=TPasElement(TPasMembersType(El).Members[i]); - if Decl is TPasType then - FinishTypeSectionEl(TPasType(Decl)); - end; - end - else - RaiseNotYetImplemented(20181226105933,El); + Decl:=TPasElement(El.Members[i]); + if Decl is TPasType then + FinishTypeSectionEl(TPasType(Decl)); + end; end; procedure TPasResolver.FinishTypeSectionEl(El: TPasType); @@ -4936,12 +5148,11 @@ procedure TPasResolver.FinishTypeSectionEl(El: TPasType); Data:=Default(TPRFindData); Data.ErrorPosEl:=ErrorEl; (TopScope as TPasIdentifierScope).IterateElements(DestName, - TopScope,@OnFindFirstElement,@Data,Abort); - if (Data.Found=nil) then + TopScope,@OnFindFirst,@Data,Abort); + //writeln('ReplaceDestType ',GetObjName(El),' DestType=',GetObjName(DestType),' DestType.Parent=',GetObjName(DestType.Parent),' RefCount=',DestType.RefCount); + if Data.Found=nil then if MustExist then begin - if DestType is TUnresolvedPendingRef then - DestType.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; RaiseIdentifierNotFound(20170216151543,DestName,ErrorEl); end else @@ -4949,16 +5160,16 @@ procedure TPasResolver.FinishTypeSectionEl(El: TPasType); if Data.Found=DestType then exit; if Decl is TPasClassOfType then begin - if Data.Found.ClassType<>TPasClassType then + if (Data.Found.ClassType<>TPasClassType) + or (TPasClassType(Data.Found).ObjKind<>okClass) then RaiseXExpectedButYFound(20170216151548,'class',GetElementTypeName(Data.Found),ErrorEl); end; // replace unresolved OldDestType:=DestType; DestType:=TPasType(Data.Found); DestType.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF}; - if OldDestType is TUnresolvedPendingRef then - OldDestType.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; OldDestType.Release{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF}; + CheckUseAsType(DestType,20190123100649,El); // check cycles if Decl is TPasPointerType then CheckPointerCycle(TPasPointerType(Decl)); @@ -4974,7 +5185,7 @@ var PtrType: TPasPointerType; begin C:=El.ClassType; - if C.InheritsFrom(TPasClassType) then + if C=TPasClassType then begin if TPasClassType(El).IsForward and (TPasClassType(El).CustomData=nil) then RaiseMsg(20170216151534,nForwardTypeNotResolved,sForwardTypeNotResolved,[El.Name],El); @@ -5208,16 +5419,18 @@ var Resolutions: array of TMethResolution; Map: TPasClassIntfMap; o: TObject; - Member: TPasElement; + Member, Parent: TPasElement; IntfProc: TPasProcedure; - FindData: TFindOverloadProcData; + FindData: TFindProcData; Abort: boolean; MethRes: TPasMethodResolution; ResolvedEl: TPasResolverResult; ProcName, IntfProcName: String; Expr: TPasExpr; + SectionScope: TPasSectionScope; begin Resolutions:=nil; + ClassScope:=nil; if El.CustomData is TPasClassScope then begin if TopScope.Element<>El then @@ -5329,12 +5542,12 @@ begin end; // search interface method in class - FindData:=Default(TFindOverloadProcData); + FindData:=Default(TFindProcData); FindData.Proc:=IntfProc; FindData.Args:=IntfProc.ProcType.Args; - FindData.Kind:=fopkSameSignature; + FindData.Kind:=fpkSameSignature; Abort:=false; - IterateElements(ProcName,@OnFindOverloadProc,@FindData,Abort); + IterateElements(ProcName,@OnFindProc,@FindData,Abort); if FindData.Found=nil then RaiseMsg(20180322143202,nNoMatchingImplForIntfMethodXFound, sNoMatchingImplForIntfMethodXFound, @@ -5347,6 +5560,26 @@ begin // ToDo: hint if method resolution is not used end; + + if El.ObjKind in okAllHelpers then + begin + // activate helper + AddActiveHelper(El); + + // cache helpers in interface, so other modules don't have to search + Parent:=El.Parent; + while Parent<>nil do + begin + if Parent.ClassType=TInterfaceSection then + begin + SectionScope:=Parent.CustomData as TPasSectionScope; + AddHelper(El,SectionScope.Helpers); + break; + end; + Parent:=Parent.Parent; + end; + end; + end; if TopScope.Element=El then @@ -5358,7 +5591,11 @@ var TypeEl: TPasType; begin TypeEl:=ResolveAliasType(El.DestType); - if TypeEl is TUnresolvedPendingRef then exit; + if TypeEl is TUnresolvedPendingRef then + begin + TypeEl.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; + exit; + end; if (TypeEl is TPasClassType) and (TPasClassType(TypeEl).ObjKind=okClass) then exit; RaiseMsg(20170216151602,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected, [El.DestType.Name,'class'],El); @@ -5369,9 +5606,14 @@ var TypeEl: TPasType; begin TypeEl:=ResolveAliasType(El.DestType); - if TypeEl is TUnresolvedPendingRef then exit; + if TypeEl is TUnresolvedPendingRef then + begin + TypeEl.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; + exit; + end; if El.DestType.Parent=El then RaiseMsg(20180429094237,nNotYetImplemented,sNotYetImplemented,['pointer of anonymous type'],El.DestType); + CheckUseAsType(El.DestType,20190123095118,El); CheckPointerCycle(El); end; @@ -5420,6 +5662,7 @@ begin end; if El.ElType=nil then RaiseNotYetImplemented(20171005235610,El,'array of const'); + CheckUseAsType(El.ElType,20190123095401,El); FinishSubElementType(El,El.ElType); end; @@ -5468,14 +5711,21 @@ begin [GetElementTypeName(SubEl),SubEl.Name],SubEl); end; end; - end; + if ProcScope.GroupScope<>nil then + begin + ProcScope.GroupScope.Free; + ProcScope.GroupScope:=nil; + end; + end + else if ProcScope.GroupScope<>nil then + RaiseInternalError(20190122142142,GetObjName(aProc)); PopScope; end; procedure TPasResolver.FinishProcedureType(El: TPasProcedureType); var ProcName: String; - FindData: TFindOverloadProcData; + FindData: TFindProcData; DeclProc, Proc, ParentProc: TPasProcedure; Abort, HasDots, IsClassConDestructor: boolean; DeclProcScope, ProcScope: TPasProcedureScope; @@ -5499,6 +5749,9 @@ begin {$ENDIF} ProcName:=Proc.Name; + if El is TPasFunctionType then + CheckUseAsType(TPasFunctionType(El).ResultEl.ResultType,20190123095743,TPasFunctionType(El).ResultEl); + if (proProcTypeWithoutIsNested in Options) and El.IsNested then RaiseInvalidProcTypeModifier(20170402120811,El,ptmIsNested,El); @@ -5567,20 +5820,21 @@ begin 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 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); + // Delphi allows virtual/override in class helpers + // But this works differently to normal virtual/override and + // requires helpers to be TInterfacedObject 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; + } + 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 @@ -5678,12 +5932,12 @@ begin if (ProcName<>'') and ProcNeedsBody(Proc) then begin // check if there is a forward declaration - ParentScope:=Scopes[ScopeCount-2]; + ParentScope:=GetParentLocalScope; //writeln('TPasResolver.FinishProcedureType FindForward2 ParentScope=',GetObjName(ParentScope),'=',GetObjName(ParentScope.Element),' Proc=',GetObjName(Proc),' at ',GetElementSourcePosStr(Proc)); - DeclProc:=FindProcOverload(ProcName,Proc,ParentScope); + DeclProc:=FindProcSameSignature(ProcName,Proc,ParentScope); //writeln('TPasResolver.FinishProcedureType FindForward3 DeclProc=',GetObjName(DeclProc),' Proc.Parent=',GetObjName(Proc.Parent)); if (DeclProc=nil) and (Proc.Parent.ClassType=TImplementationSection) then - DeclProc:=FindProcOverload(ProcName,Proc, + DeclProc:=FindProcSameSignature(ProcName,Proc, (Proc.GetModule.InterfaceSection.CustomData) as TPasScope); //writeln('TPasResolver.FinishProcedureType FindForward4 ',GetObjName(DeclProc),' at ',GetElementSourcePosStr(DeclProc)); if (DeclProc<>nil) then @@ -5725,12 +5979,12 @@ begin if ProcName<>'' then begin // check for invalid overloads - FindData:=Default(TFindOverloadProcData); + FindData:=Default(TFindProcData); FindData.Proc:=Proc; FindData.Args:=Proc.ProcType.Args; - FindData.Kind:=fopkProc; + FindData.Kind:=fpkProc; Abort:=false; - IterateElements(ProcName,@OnFindOverloadProc,@FindData,Abort); + IterateElements(ProcName,@OnFindProc,@FindData,Abort); end; end else if El.Name<>'' then @@ -5784,27 +6038,31 @@ procedure TPasResolver.FinishMethodDeclHeader(Proc: TPasProcedure); var Abort, IsClassConDestructor: boolean; ClassOrRecScope: TPasClassOrRecordScope; - FindData: TFindOverloadProcData; + FindData: TFindProcData; OverloadProc: TPasProcedure; ProcScope: TPasProcedureScope; i: Integer; + ParentScope: TPasScope; begin Proc.ProcType.IsOfObject:=true; ProcScope:=TopScope as TPasProcedureScope; + ParentScope:=Scopes[ScopeCount-2]; // ToDo: store the scanner flags *before* it has parsed the token after the proc StoreScannerFlagsInProc(ProcScope); - ClassOrRecScope:=Scopes[ScopeCount-2] as TPasClassOrRecordScope; - ProcScope.ClassOrRecordScope:=ClassOrRecScope; - FindData:=Default(TFindOverloadProcData); - FindData.Proc:=Proc; - FindData.Args:=Proc.ProcType.Args; - FindData.Kind:=fopkMethod; - Abort:=false; + ClassOrRecScope:=Proc.Parent.CustomData as TPasClassOrRecordScope; + ProcScope.ClassRecScope:=ClassOrRecScope; + FindData:=Default(TFindProcData); IsClassConDestructor:=(Proc.ClassType=TPasClassConstructor) or (Proc.ClassType=TPasClassDestructor); if not IsClassConDestructor then - ClassOrRecScope.IterateElements(Proc.Name,ClassOrRecScope, - @OnFindOverloadProc,@FindData,Abort); + begin + FindData.Proc:=Proc; + FindData.Args:=Proc.ProcType.Args; + FindData.Kind:=fpkMethod; + Abort:=false; + ParentScope.IterateElements(Proc.Name,ClassOrRecScope, + @OnFindProc,@FindData,Abort); + end; if FindData.Found=nil then begin @@ -5870,6 +6128,7 @@ var ClassOrRecScope: TPasClassOrRecordScope; SelfArg: TPasArgument; p: Integer; + SelfType, LoSelfType: TPasType; begin if ImplProc.IsExternal then RaiseMsg(20170216151715,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(ImplProc),'external'],ImplProc); @@ -5894,17 +6153,19 @@ begin // search proc in class/record ImplProcScope:=ImplProc.CustomData as TPasProcedureScope; - ClassOrRecScope:=ImplProcScope.ClassOrRecordScope; + ClassOrRecScope:=ImplProcScope.ClassRecScope; if ClassOrRecScope=nil then RaiseInternalError(20161013172346); ClassRecType:=NoNil(ClassOrRecScope.Element) as TPasMembersType; + if ImplProcScope.GroupScope=nil then + RaiseInternalError(20190120135017); if ImplProc.ClassType=TPasClassConstructor then DeclProc:=ClassOrRecScope.ClassConstructor else if ImplProc.ClassType=TPasClassDestructor then DeclProc:=ClassOrRecScope.ClassDestructor else - DeclProc:=FindProcOverload(ProcName,ImplProc,ClassOrRecScope); + DeclProc:=FindProcSameSignature(ProcName,ImplProc,ClassOrRecScope); if DeclProc=nil then RaiseIdentifierNotFound(20170216151720,ImplProc.Name,ImplProc.ProcType); DeclProcScope:=DeclProc.CustomData as TPasProcedureScope; @@ -5933,9 +6194,11 @@ begin or (DeclProc.ClassType=TPasClassProcedure) or (DeclProc.ClassType=TPasClassFunction) then begin - if ClassOrRecScope is TPasClassScope then + if (ClassOrRecScope is TPasClassScope) + and (TPasClassScope(ClassOrRecScope).CanonicalClassOf<>nil) then begin - // 'Self' in a class proc is the hidden classtype argument + // 'Self' in a class method is the hidden classtype argument + // Note: this is true in classes and helpers SelfArg:=TPasArgument.Create('Self',DeclProc); ImplProcScope.SelfArg:=SelfArg; {$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF} @@ -5949,16 +6212,24 @@ begin end else begin - // 'Self' in a proc is the hidden instance argument + // 'Self' in a method is the hidden instance argument SelfArg:=TPasArgument.Create('Self',DeclProc); ImplProcScope.SelfArg:=SelfArg; {$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF} - SelfArg.ArgType:=ClassRecType; - if ClassRecType is TPasRecordType then - SelfArg.Access:=argDefault + SelfType:=ClassRecType; + if (SelfType.ClassType=TPasClassType) + and (TPasClassType(SelfType).HelperForType<>nil) then + begin + // in a helper Self is a var argument of the helped variable + SelfType:=TPasClassType(SelfType).HelperForType; + end; + LoSelfType:=ResolveAliasType(SelfType); + if LoSelfType is TPasClassType then + SelfArg.Access:=argConst else - SelfArg.Access:=argConst; - ClassRecType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF}; + SelfArg.Access:=argVar; + SelfArg.ArgType:=SelfType; + SelfType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF}; AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple); end; end; @@ -6032,6 +6303,7 @@ begin if (El.Parent is TPasRecordType) and (El.VarType=El.Parent) then RaiseMsg(20181218173631,nTypeXIsNotYetCompletelyDefined, sTypeXIsNotYetCompletelyDefined,[El.VarType.Name],El); + CheckUseAsType(El.VarType,20190123095916,El); if El.Expr<>nil then CheckAssignCompatibility(El,El.Expr,true); end @@ -6106,6 +6378,7 @@ var begin // new property or redeclaration PropType:=PropEl.VarType; + CheckUseAsType(PropEl.VarType,20190123100011,PropEl); end else begin @@ -6308,7 +6581,7 @@ var okInterface: // e.g. property IntfVar: IntfType read Getter implements IntfType2 // check that IntfType is IntfType2 - if CheckClassIsClass(PropType,IntfType,Expr)=cIncompatible then + if CheckClassIsClass(PropType,IntfType)=cIncompatible then RaiseIncompatibleType(20180323173746,nIncompatibleTypesGotExpected, [],OrigIntfType,PropType,Expr); else @@ -6416,7 +6689,7 @@ var end; var - ResultType: TPasType; + ResultType, aType: TPasType; MembersType: TPasMembersType; AccEl: TPasElement; Proc: TPasProcedure; @@ -6427,6 +6700,7 @@ var m: TVariableModifier; IndexVal: TResEvalValue; AncIndexExpr: TPasExpr; + CurClass: TPasClassType; begin CheckTopScope(TPasPropertyScope); PopScope; @@ -6440,10 +6714,13 @@ begin PropType:=nil; MembersType:=PropEl.Parent as TPasMembersType; ClassOrRecScope:=NoNil(MembersType.CustomData) as TPasClassOrRecordScope; + ClassScope:=nil; + CurClass:=nil; if ClassOrRecScope is TPasClassScope then - ClassScope:=TPasClassScope(ClassOrRecScope) - else - ClassScope:=nil; + begin + ClassScope:=TPasClassScope(ClassOrRecScope); + CurClass:=TPasClassType(MembersType); + end; AncestorProp:=nil; GetPropType; IndexVal:=nil; @@ -6649,6 +6926,14 @@ begin end; if PropEl.IsDefault then begin + if (CurClass<>nil) and (CurClass.HelperForType<>nil) then + begin + aType:=ResolveAliasType(CurClass.HelperForType); + if not (aType is TPasMembersType) then + RaiseMsg(20190117125004,nDefaultPropertyNotAllowedInHelperForX, + sDefaultPropertyNotAllowedInHelperForX, + [GetTypeDescription(CurClass.HelperForType)],PropEl); + end; // set default array property if (ClassOrRecScope.DefaultProperty<>nil) and (ClassOrRecScope.DefaultProperty.Parent=PropEl.Parent) then @@ -6663,6 +6948,8 @@ end; procedure TPasResolver.FinishArgument(El: TPasArgument); begin + if El.ArgType<>nil then + CheckUseAsType(El.ArgType,20190123100049,El); if El.ValueExpr<>nil then begin ResolveExpr(El.ValueExpr,rraRead); @@ -6716,6 +7003,7 @@ var j: integer; IntfType, IntfTypeRes, HelperForType, AncestorHelperFor: TPasType; ResIntfList, Members: TFPList; + GroupScope: TPasGroupScope; begin if aClass.IsForward then begin @@ -6763,6 +7051,9 @@ begin if aClass.IsExternal then RaiseMsg(20190116192722,nIllegalQualifier,sIllegalQualifier,['external'],aClass); HelperForType:=ResolveAliasType(aClass.HelperForType); + if (aClass=HelperForType) or (aClass.HasParent(HelperForType)) then + RaiseMsg(20190118190935,nTypeXIsNotYetCompletelyDefined, + sTypeXIsNotYetCompletelyDefined,[HelperForType.Name],aClass); case aClass.ObjKind of okClassHelper: begin @@ -6788,7 +7079,7 @@ begin and (HelperForType.CustomData is TResElDataBaseType)) then else RaiseMsg(20190116200304,nTypeXCannotBeExtendedByATypeHelper, - sTypeXCannotBeExtendedByATypeHelper,[aClass.HelperForType.Name],aClass); + sTypeXCannotBeExtendedByATypeHelper,[GetTypeDescription(HelperForType)],aClass); end else begin @@ -6796,32 +7087,29 @@ begin if (HelperForType.ClassType=TPasRecordType) then else RaiseMsg(20190116200519,nTypeXCannotBeExtendedByATypeHelper, - sTypeXCannotBeExtendedByATypeHelper,[aClass.HelperForType.Name],aClass); + sTypeXCannotBeExtendedByATypeHelper,[GetTypeDescription(HelperForType)],aClass); end; okTypeHelper: begin - if HelperForType.ClassType=TPasUnresolvedSymbolRef then + 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 (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; + if TPasClassType(HelperForType).IsForward then + RaiseMsg(20190116200940,nTypeXIsNotYetCompletelyDefined, + sTypeXIsNotYetCompletelyDefined,[HelperForType.Name],aClass); + end + else + RaiseMsg(20190116200304,nTypeXCannotBeExtendedByATypeHelper, + sTypeXCannotBeExtendedByATypeHelper,[GetTypeDescription(HelperForType)],aClass); end; end; end @@ -6900,7 +7188,8 @@ begin if AncestorClassEl.ObjKind<>aClass.ObjKind then RaiseXExpectedButYFound(20180321152107,GetElementTypeName(aClass)+' type', GetElementTypeName(AncestorClassEl)+' type',aClass); - if aClass.ObjKind in [okClassHelper,okRecordHelper,okTypeHelper] then + + if aClass.ObjKind in okAllHelpers then begin HelperForType:=ResolveAliasType(aClass.HelperForType); AncestorHelperFor:=ResolveAliasType(AncestorClassEl.HelperForType); @@ -6908,8 +7197,8 @@ begin // 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 + and (CheckClassIsClass(HelperForType,AncestorHelperFor)<>cIncompatible) then + // helper for descendant class of ancestor helper for -> ok else RaiseMsg(20190116203931,nDerivedXMustExtendASubClassY,sDerivedXMustExtendASubClassY, [GetElementTypeName(aClass),AncestorClassEl.HelperForType.Name],aClass); @@ -6954,9 +7243,7 @@ begin {$IFDEF VerbosePasResolver} //writeln('TPasResolver.FinishAncestors ',GetObjName(aClass.CustomData)); {$ENDIF} - PushScope(aClass,ScopeClass_Class); - ClassScope:=TPasClassScope(TopScope); - ClassScope.VisibilityContext:=aClass; + ClassScope:=TPasClassScope(CreateScope(aClass,ScopeClass_Class)); Include(ClassScope.Flags,pcsfAncestorResolved); if IsSealed then Include(ClassScope.Flags,pcsfSealed); @@ -6971,9 +7258,10 @@ begin end; if bsTypeInfo in CurrentParser.Scanner.CurrentBoolSwitches then Include(ClassScope.Flags,pcsfPublished); - if aClass.ObjKind=okClass then + + if aClass.ObjKind in ([okClass]+okAllHelpers) then begin - // create canonical class-of for the "Self" in class functions + // create canonical class-of for the "Self" in non static class functions CanonicalSelf:=TPasClassOfType.Create('Self',aClass); ClassScope.CanonicalClassOf:=CanonicalSelf; {$IFDEF CheckPasTreeRefCount}CanonicalSelf.RefIds.Add('TPasClassScope.CanonicalClassOf');{$ENDIF} @@ -6984,6 +7272,10 @@ begin CanonicalSelf.SourceLinenumber:=aClass.SourceLinenumber; end; + // push scope (must be done after setting aClass.AncestorScope) + GroupScope:=PushGroupScope(aClass); + GroupScope.VisibilityContext:=aClass; + // check interfaces if aClass.Interfaces.Count>0 then begin @@ -7041,7 +7333,7 @@ begin RaiseXExpectedButYFound(20180323132601,'interface type', GetResolverResultDescription(ResolvedEl),El.InterfaceName); aClass:=El.Parent as TPasClassType; - i:=IndexOfImplementedInterface(aClass,TpasType(ResolvedEl.IdentEl)); + i:=IndexOfImplementedInterface(aClass,TPasType(ResolvedEl.IdentEl)); if i<0 then RaiseXExpectedButYFound(20180323133055,'interface type', GetResolverResultDescription(ResolvedEl),El.InterfaceName); @@ -7727,11 +8019,11 @@ begin begin // check range EnumeratorFound:=CheckForIn(Loop,VarResolved,StartResolved); - if (not EnumeratorFound) and (StartResolved.BaseType=btContext) then + if (not EnumeratorFound) + and not (StartResolved.IdentEl is TPasType) + and (rrfReadable in StartResolved.Flags) then begin - TypeEl:=StartResolved.LoTypeEl; - if TypeEl is TPasMembersType then - EnumeratorFound:=CheckForInClassOrRec(Loop,VarResolved,StartResolved); + EnumeratorFound:=CheckForInClassOrRec(Loop,VarResolved,StartResolved); end; if not EnumeratorFound then @@ -8274,10 +8566,13 @@ end; procedure TPasResolver.ResolveInherited(El: TInheritedExpr; Access: TResolvedRefAccess); var - ProcScope, DeclProcScope, SelfScope: TPasProcedureScope; + SelfScope: TPasProcedureScope; AncestorScope: TPasClassScope; ClassRecScope: TPasClassOrRecordScope; DeclProc, AncestorProc: TPasProcedure; + aClass: TPasClassType; + HelperForType: TPasType; + InhScope: TPasInheritedScope; begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.ResolveInherited El.Parent=',GetTreeDbg(El.Parent)); @@ -8291,39 +8586,69 @@ begin end; // 'inherited;' without expression - ProcScope:=GetInheritedExprScope(El); - SelfScope:=ProcScope.GetSelfScope; + SelfScope:=GetSelfScope(El); if SelfScope=nil then RaiseMsg(20170216152141,nInheritedOnlyWorksInMethods,sInheritedOnlyWorksInMethods,[],El); - ClassRecScope:=SelfScope.ClassOrRecordScope; + DeclProc:=SelfScope.DeclarationProc; + if DeclProc=nil then + RaiseNotYetImplemented(20190121172251,El); + ClassRecScope:=SelfScope.ClassRecScope; - AncestorScope:=nil; - if ClassRecScope is TPasClassScope then - begin - // inherited in class method - AncestorScope:=TPasClassScope(ClassRecScope).AncestorScope; - if AncestorScope=nil then - begin - // 'inherited;' without ancestor class is silently ignored - exit; - end; - end - else + if not (ClassRecScope is TPasClassScope) then begin // inherited in record method RaiseMsg(20181218194022,nTheUseOfXisNotAllowedInARecord,sTheUseOfXisNotAllowedInARecord, ['inherited'],El); end; + AncestorProc:=nil; - // search ancestor in element, i.e. 'inherited' expression - DeclProc:=SelfScope.DeclarationProc; - DeclProcScope:=DeclProc.CustomData as TPasProcedureScope; - AncestorProc:=DeclProcScope.OverriddenProc; - if AncestorProc=nil then + // inherited in class/interface/helper method + aClass:=ClassRecScope.Element as TPasClassType; + HelperForType:=ResolveAliasType(aClass.HelperForType); + //writeln('TPasResolver.ResolveInherited aClass=',GetObjName(aClass),' HelperForType=',GetObjName(HelperForType)); + if HelperForType is TPasMembersType then begin - // 'inherited;' without ancestor method is silently ignored - exit; + // inherited; inside helper -> skip helper ancestors and search in HelperForType + if msDelphi in CurrentParser.CurrentModeswitches then + begin + // Delphi skips ancestors and HelperForType + if not (HelperForType is TPasClassType) then + // 'inherited;' without ancestor class is silently ignored + exit; + AncestorScope:=TPasClassScope(HelperForType.CustomData).AncestorScope; + if AncestorScope=nil then + // 'inherited;' without ancestor class is silently ignored + exit; + InhScope:=PushInheritedScope(TPasMembersType(AncestorScope.Element),true,nil); + end + else + begin + // ObjFPC searches first in HelperForType and its ancestors, then in + // own ancestors + AncestorScope:=TPasClassScope(aClass.CustomData).AncestorScope; + InhScope:=PushInheritedScope(TPasMembersType(HelperForType),false, + AncestorScope); + end; + end + else + begin + // inherited; inside class/interface method + // -> search in ancestor and its helper(s) + AncestorScope:=TPasClassScope(ClassRecScope).AncestorScope; + if AncestorScope=nil then + // 'inherited;' without ancestor class is silently ignored + exit; + InhScope:=PushInheritedScope(TPasMembersType(AncestorScope.Element),true,nil); end; + AncestorProc:=FindProcSameSignature(DeclProc.Name,DeclProc,InhScope); + PopScope; + if AncestorProc=nil then + // 'inherited;' without ancestor DeclProc is silently ignored + exit; + + if not (AncestorProc.Parent is TPasMembersType) then + RaiseNotYetImplemented(20190121181234,El); // inconsistency + CreateReference(AncestorProc,El,Access); if AncestorProc.IsAbstract then RaiseMsg(20170216152144,nAbstractMethodsCannotBeCalledDirectly, @@ -8336,41 +8661,66 @@ procedure TPasResolver.ResolveInheritedCall(El: TBinaryExpr; // El.left is TInheritedExpr // El.right is the identifier and parameters var - ProcScope, SelfScope: TPasProcedureScope; - AncestorScope: TPasClassScope; + SelfScope: TPasProcedureScope; ClassRecScope: TPasClassOrRecordScope; - AncestorClass: TPasClassType; - InhScope: TPasDotClassScope; + AncestorClass, aClass: TPasClassType; + HelperForType: TPasType; + OnlyTypeMembers: Boolean; + Proc: TPasProcedure; + AncestorScope: TPasClassScope; + InhScope: TPasInheritedScope; begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.ResolveInheritedCall El=',GetTreeDbg(El)); {$ENDIF} - ProcScope:=GetInheritedExprScope(El); - SelfScope:=ProcScope.GetSelfScope; + SelfScope:=GetSelfScope(El); if SelfScope=nil then RaiseMsg(20170216152148,nInheritedOnlyWorksInMethods,sInheritedOnlyWorksInMethods,[],El); - ClassRecScope:=SelfScope.ClassOrRecordScope; + ClassRecScope:=SelfScope.ClassRecScope; - AncestorScope:=nil; - if ClassRecScope is TPasClassScope then + if not (ClassRecScope is TPasClassScope) then + // inherited in a method of a record + RaiseMsg(20181218194436,nTheUseOfXisNotAllowedInARecord,sTheUseOfXisNotAllowedInARecord, + ['inherited'],El); + + Proc:=TPasProcedure(SelfScope.Element); + OnlyTypeMembers:=IsClassMethod(Proc); + + // inherited in a method of a class/interface/helper + aClass:=TPasClassType(ClassRecScope.Element); + AncestorScope:=TPasClassScope(ClassRecScope).AncestorScope; + if aClass.ObjKind in okAllHelpers then begin - // inherited in class method - AncestorScope:=TPasClassScope(ClassRecScope).AncestorScope; - if AncestorScope=nil then - RaiseMsg(20170216152151,nInheritedNeedsAncestor,sInheritedNeedsAncestor,[],El.left); + HelperForType:=ResolveAliasType(aClass.HelperForType); + if HelperForType is TPasMembersType then + begin + // record helper(ancestor) for aRecord + // or class helper(ancestor) for aClass + // -> search in helperfortype, then in ancestors + InhScope:=PushInheritedScope(TPasMembersType(HelperForType),false, + AncestorScope); + InhScope.OnlyTypeMembers:=OnlyTypeMembers; + ResolveExpr(El.right,Access); + PopScope; + exit; + end + else + begin + // type helper(ancestortype) for simpletype -> search in ancestortype + end; end else begin - // inherited in record method - RaiseMsg(20181218194436,nTheUseOfXisNotAllowedInARecord,sTheUseOfXisNotAllowedInARecord, - ['inherited'],El); + // class or interface -> search in ancestor and its helpers end; - + // search in ancestor and its helpers + if AncestorScope=nil then + RaiseMsg(20170216152151,nInheritedNeedsAncestor,sInheritedNeedsAncestor,[],El.left); // search call in ancestor AncestorClass:=TPasClassType(AncestorScope.Element); - InhScope:=PushClassDotScope(AncestorClass); - InhScope.InheritedExpr:=true; + InhScope:=PushInheritedScope(AncestorClass,true,nil); + InhScope.OnlyTypeMembers:=OnlyTypeMembers; ResolveExpr(El.right,Access); PopScope; end; @@ -8438,8 +8788,9 @@ var LeftResolved: TPasResolverResult; Left: TPasExpr; RecordEl: TPasRecordType; - RecordScope: TPasDotRecordScope; + RecordScope: TPasDotClassOrRecordScope; LTypeEl: TPasType; + DotScope: TPasDotBaseScope; begin if El.CustomData is TResolvedReference then exit; // for example, when a.b has a dotted unit name @@ -8478,6 +8829,8 @@ begin if LTypeEl.ClassType=TPasClassType then begin ClassEl:=TPasClassType(LTypeEl); + if ClassEl.HelperForType<>nil then + RaiseHelpersCannotBeUsedAsType(20190123093438,El); ClassScope:=PushClassDotScope(ClassEl); if LeftResolved.IdentEl is TPasType then // e.g. TFPMemoryImage.FindHandlerFromExtension() @@ -8523,15 +8876,24 @@ begin if LeftResolved.IdentEl is TPasType then begin // e.g. TShiftState.ssAlt - PushEnumDotScope(TPasEnumType(LTypeEl)); + DotScope:=PushEnumDotScope(TPasEnumType(LTypeEl)); + DotScope.OnlyTypeMembers:=true; ResolveExpr(El.right,Access); PopScope; exit; end; - end - else - RaiseMsg(20170216152541,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot, - [GetElementTypeName(LeftResolved.LoTypeEl)],El); + end; + // default: search for type helpers + DotScope:=PushHelperDotScope(LTypeEl); + if DotScope<>nil then + begin + if LeftResolved.IdentEl is TPasType then + // e.g. TSet.HelperProc + DotScope.OnlyTypeMembers:=true; + ResolveExpr(El.right,Access); + PopScope; + exit; + end; end; {$IFDEF VerbosePasResolver} @@ -9219,34 +9581,53 @@ begin end; function TPasResolver.ResolveAccessor(Expr: TPasExpr): TPasElement; + + function SubResolvePrimitive(Prim: TPrimitiveExpr): TPasElement; + var + FindData: TPRFindData; + Ref: TResolvedReference; + Scope: TPasScope; + Abort: boolean; + begin + if Prim.Kind<>pekIdent then + RaiseXExpectedButYFound(20170216151746,'class',Prim.Value,Prim); + // search in class and ancestors, not in unit interface + Scope:=TopScope; + FindData:=Default(TPRFindData); + FindData.ErrorPosEl:=Expr; + Abort:=false; + Scope.IterateElements(Prim.Value,Scope,@OnFindFirst,@FindData,Abort); + Result:=FindData.Found; + if Result=nil then + RaiseIdentifierNotFound(20170216151749,Prim.Value,Prim); + Ref:=CreateReference(Result,Prim,rraRead); + CheckFoundElementVisibility(FindData,Ref); + end; + var Prim: TPrimitiveExpr; DeclEl: TPasElement; - Identifier: TPasIdentifier; - Scope: TPasIdentifierScope; begin if Expr.ClassType=TBinaryExpr then begin + DeclEl:=nil; if (TBinaryExpr(Expr).left is TPrimitiveExpr) then begin Prim:=TPrimitiveExpr(TBinaryExpr(Expr).left); - if Prim.Kind<>pekIdent then - RaiseXExpectedButYFound(20170216151746,'class',Prim.Value,Prim); - Scope:=TopScope as TPasIdentifierScope; - // search in class and ancestors, not in unit interface - Identifier:=Scope.FindIdentifier(Prim.Value); - if Identifier=nil then - RaiseIdentifierNotFound(20170216151749,Prim.Value,Prim); - DeclEl:=Identifier.Element; - if DeclEl.ClassType<>TPasClassType then + DeclEl:=SubResolvePrimitive(Prim); + if not (DeclEl is TPasMembersType) then RaiseXExpectedButYFound(20170216151752,'class',GetElementTypeName(DeclEl),Prim); - CreateReference(DeclEl,Prim,rraRead); end else RaiseMsg(20170216151754,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TBinaryExpr(Expr).OpCode]],Expr); if TBinaryExpr(Expr).OpCode<>eopSubIdent then RaiseMsg(20170216151757,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TBinaryExpr(Expr).OpCode]],Expr); - PushClassDotScope(TPasClassType(DeclEl)); + if DeclEl.ClassType=TPasClassType then + PushClassDotScope(TPasClassType(DeclEl)) + else if DeclEl.ClassType=TPasRecordType then + PushRecordDotScope(TPasRecordType(DeclEl)) + else + RaiseMsg(20190123145559,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TBinaryExpr(Expr).OpCode]],Expr); Expr:=TBinaryExpr(Expr).right; Result:=ResolveAccessor(Expr); PopScope; @@ -9254,16 +9635,7 @@ begin else if Expr.ClassType=TPrimitiveExpr then begin Prim:=TPrimitiveExpr(Expr); - if Prim.Kind<>pekIdent then - RaiseXExpectedButYFound(20170216151800,'identifier',Prim.Value,Prim); - Scope:=TopScope as TPasIdentifierScope; - // search in class and ancestors, not in unit interface - Identifier:=Scope.FindIdentifier(Prim.Value); - if Identifier=nil then - RaiseIdentifierNotFound(20170216151803,Prim.Value,Prim); - DeclEl:=Identifier.Element; - CreateReference(DeclEl,Prim,rraRead); - Result:=DeclEl; + Result:=SubResolvePrimitive(Prim); end else RaiseNotYetImplemented(20160922163436,Expr); @@ -9591,6 +9963,8 @@ begin end; procedure TPasResolver.AddRecordType(El: TPasRecordType); +var + Scope: TPasScope; begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.AddRecordType ',GetObjName(El),' Parent=',GetObjName(El.Parent)); @@ -9603,7 +9977,10 @@ begin end; if El.Parent.ClassType<>TPasVariant then - PushScope(El,TPasRecordScope); + begin + Scope:=PushScope(El,TPasRecordScope); + Scope.VisibilityContext:=El; + end; end; procedure TPasResolver.AddClassType(El: TPasClassType); @@ -9611,16 +9988,20 @@ procedure TPasResolver.AddClassType(El: TPasClassType); var Duplicate: TPasIdentifier; ForwardDecl: TPasClassType; - CurScope: TPasIdentifierScope; + CurScope, LocalScope: TPasIdentifierScope; begin {$IFDEF VerbosePasResolver} - writeln('TPasResolver.AddClassType ',GetObjName(El),' Parent=',GetObjName(El.Parent),' ',GetElementSourcePosStr(El)); + //writeln('TPasResolver.AddClassType ',GetObjName(El),' Parent=',GetObjName(El.Parent),' ',GetElementSourcePosStr(El)); {$ENDIF} if not (TopScope is TPasIdentifierScope) then RaiseInvalidScopeForElement(20160922163510,El); CurScope:=TPasIdentifierScope(TopScope); - Duplicate:=CurScope.FindLocalIdentifier(El.Name); + if CurScope is TPasGroupScope then + LocalScope:=TPasGroupScope(CurScope).Scopes[0] + else + LocalScope:=CurScope; + Duplicate:=LocalScope.FindLocalIdentifier(El.Name); //if Duplicate<>nil then //writeln(' Duplicate=',GetObjName(Duplicate.Element),' ',ord(Duplicate.Kind)); @@ -9677,6 +10058,7 @@ end; procedure TPasResolver.AddEnumType(El: TPasEnumType); var CanonicalSet: TPasSetType; + EnumScope: TPasEnumTypeScope; begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.AddEnumType ',GetObjName(El)); @@ -9684,7 +10066,7 @@ begin if not (TopScope is TPasIdentifierScope) then RaiseInvalidScopeForElement(20160929205732,El); AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple); - PushScope(El,TPasEnumTypeScope); + EnumScope:=TPasEnumTypeScope(PushScope(El,TPasEnumTypeScope)); // add canonical set if El.Parent is TPasSetType then begin @@ -9699,7 +10081,7 @@ begin CanonicalSet.EnumType:=El; El.AddRef{$IFDEF CheckPasTreeRefCount}('TPasSetType.EnumType'){$ENDIF}; end; - TPasEnumTypeScope(TopScope).CanonicalSet:=CanonicalSet; + EnumScope.CanonicalSet:=CanonicalSet; end; procedure TPasResolver.AddEnumValue(El: TPasEnumValue); @@ -9724,7 +10106,9 @@ begin for i:=ScopeCount-2 downto 0 do begin Scope:=Scopes[i]; - if (Scope is TPasClassScope) or (Scope is TPasRecordScope) then + if Scope is TPasGroupScope then + Scope:=TPasGroupScope(Scope).Scopes[0]; + if Scope is TPasClassOrRecordScope then begin // class or record: add if not duplicate Old:=TPasIdentifierScope(Scope).FindIdentifier(El.Name); @@ -9753,7 +10137,7 @@ begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.AddProperty ',GetObjName(El)); {$ENDIF} - if not (TopScope is TPasClassOrRecordScope) then + if not (GetLocalScope is TPasClassOrRecordScope) then RaiseInvalidScopeForElement(20160922163520,El); AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple); PushScope(El,TPasPropertyScope); @@ -9782,21 +10166,30 @@ var Identifier: TPasIdentifier; ClassOrRecScope: TPasClassOrRecordScope; C: TClass; + CurScope: TPasScope; + LocalScope: TPasScope; begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.AddProcedure ',GetObjName(El)); {$ENDIF} + + CurScope:=TopScope; + if CurScope.ClassType=TPasGroupScope then + LocalScope:=TPasGroupScope(CurScope).Scopes[0] + else + LocalScope:=CurScope; + ProcName:=El.Name; if El.Name<>'' then begin // named proc - if not (TopScope is TPasIdentifierScope) then + if not (LocalScope is TPasIdentifierScope) then RaiseInvalidScopeForElement(20160922163522,El); end else begin // anonymous proc - C:=TopScope.ClassType; + C:=LocalScope.ClassType; if (C=ScopeClass_InitialFinalization) or C.InheritsFrom(TPasProcedureScope) or (C=TPasWithScope) @@ -9817,9 +10210,9 @@ begin begin if ProcName='' then RaiseNotYetImplemented(20181231145302,El); - if not (TopScope is TPasClassOrRecordScope) then + if not (LocalScope is TPasClassOrRecordScope) then RaiseInvalidScopeForElement(20181231143831,El); - ClassOrRecScope:=TPasClassOrRecordScope(TopScope); + ClassOrRecScope:=TPasClassOrRecordScope(LocalScope); if El.ClassType=TPasClassConstructor then AddClassConDestructor(ClassOrRecScope,TPasProcedure(ClassOrRecScope.ClassConstructor)) else @@ -9831,7 +10224,7 @@ begin then begin // add proc name to scope - AddIdentifier(TPasIdentifierScope(TopScope),ProcName,El,pikProc); + AddIdentifier(TPasIdentifierScope(CurScope),ProcName,El,pikProc); end; ProcScope:=TPasProcedureScope(PushScope(El,FScopeClass_Proc)); @@ -9883,7 +10276,8 @@ begin ClassOrRecType:=TPasMembersType(CurEl); if ClassOrRecType is TPasClassType then begin - if TPasClassType(ClassOrRecType).ObjKind<>okClass then + if not (TPasClassType(ClassOrRecType).ObjKind in + ([okClass]+okAllHelpers)) then begin aClassName:=LeftStr(El.Name,length(El.Name)-length(ProcName)-1); RaiseXExpectedButYFound(20180321161722, @@ -9902,7 +10296,14 @@ begin RaiseNotYetImplemented(20161013170956,El); ProcScope.VisibilityContext:=ClassOrRecType; - ProcScope.ClassOrRecordScope:=NoNil(ClassOrRecType.CustomData) as TPasClassOrRecordScope; + ProcScope.ClassRecScope:=NoNil(ClassOrRecType.CustomData) as TPasClassOrRecordScope; + ProcScope.GroupScope:=CreateGroupScope(ClassOrRecType); + while ClassOrRecType.Parent is TPasMembersType do + begin + ClassOrRecType:=TPasMembersType(ClassOrRecType.Parent); + GroupScope_AddTypeAndAncestors(ProcScope.GroupScope,ClassOrRecType); + end; + end;// HasDot=true end; @@ -9911,28 +10312,30 @@ var ProcType: TPasProcedureType; i: Integer; Arg: TPasArgument; + CurScope: TPasScope; begin if (El.Name='') then RaiseInternalError(20160922163526,GetObjName(El)); {$IFDEF VerbosePasResolver} writeln('TPasResolver.AddArgument ',GetObjName(El)); {$ENDIF} - if (TopScope=nil) then + CurScope:=TopScope; + if (CurScope=nil) then RaiseInvalidScopeForElement(20160922163529,El); if El.Parent.ClassType=TPasProperty then begin - if TopScope.ClassType<>TPasPropertyScope then + if CurScope.ClassType<>TPasPropertyScope then RaiseInvalidScopeForElement(20161014124530,El); - AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple); + AddIdentifier(TPasIdentifierScope(CurScope),El.Name,El,pikSimple); end else if El.Parent is TPasProcedureType then begin ProcType:=TPasProcedureType(El.Parent); if ProcType.Parent is TPasProcedure then begin - if TopScope.ClassType<>FScopeClass_Proc then + if CurScope.ClassType<>FScopeClass_Proc then RaiseInvalidScopeForElement(20160922163529,El,GetObjName(TopScope)); - AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple); + AddIdentifier(TPasIdentifierScope(CurScope),El.Name,El,pikSimple); end else begin @@ -9949,8 +10352,11 @@ begin end; procedure TPasResolver.AddFunctionResult(El: TPasResultElement); +var + CurScope: TPasScope; begin - if TopScope.ClassType<>FScopeClass_Proc then exit; + CurScope:=TopScope; + if CurScope.ClassType<>FScopeClass_Proc then exit; if El.Parent is TPasProcedureType then begin if not (El.Parent.Parent is TPasProcedure) then @@ -9958,7 +10364,7 @@ begin end else if not (El.Parent is TPasProcedure) then exit; - AddIdentifier(TPasProcedureScope(TopScope),ResolverResultVar,El,pikSimple); + AddIdentifier(TPasProcedureScope(CurScope),ResolverResultVar,El,pikSimple); end; procedure TPasResolver.AddExceptOn(El: TPasImplExceptOn); @@ -9967,13 +10373,10 @@ begin end; procedure TPasResolver.AddWithDo(El: TPasImplWithDo); -var - WithScope: TPasWithScope; begin if TPasWithScope.FreeOnPop then RaiseInternalError(20181210162344); - WithScope:=TPasWithScope(CreateScope(El,TPasWithScope)); - PushScope(WithScope); + PushScope(El,TPasWithScope); end; procedure TPasResolver.AddProcedureBody(El: TProcedureBody); @@ -10357,14 +10760,14 @@ begin begin if TPasClassType(LeftTypeEl).ObjKind=TPasClassType(RightTypeEl).ObjKind then begin - if CheckSrcIsADstType(RightResolved,LeftResolved,Bin)<>cIncompatible then + if CheckSrcIsADstType(RightResolved,LeftResolved)<>cIncompatible then begin // e.g. if obj is TFPMemoryImage then ; // Note: at compile time the check is reversed: right must inherit from left SetBaseType(btBoolean); exit; end - else if CheckSrcIsADstType(LeftResolved,RightResolved,Bin)<>cIncompatible then + else if CheckSrcIsADstType(LeftResolved,RightResolved)<>cIncompatible then begin // e.g. if Image is TObject then ; // This is useful after some unchecked typecast -> allow @@ -10402,7 +10805,7 @@ begin begin // e.g. if Image is ImageClass then ; if (CheckClassesAreRelated(LeftResolved.LoTypeEl, - TPasClassOfType(RightTypeEl).DestType,Bin)<>cIncompatible) then + TPasClassOfType(RightTypeEl).DestType)<>cIncompatible) then begin SetBaseType(btBoolean); exit; @@ -10424,7 +10827,7 @@ begin begin // e.g. if ImageClass is TFPMemoryImage then ; // Note: at compile time the check is reversed: right must inherit from left - if CheckClassIsClass(RightResolved.LoTypeEl,LeftTypeEl,Bin)<>cIncompatible then + if CheckClassIsClass(RightResolved.LoTypeEl,LeftTypeEl)<>cIncompatible then begin SetBaseType(btBoolean); exit; @@ -10435,7 +10838,7 @@ begin // e.g. if ImageClassA is ImageClassB then ; // or if ImageClassA is TFPImageClass then ; RightTypeEl:=ResolveAliasType(TPasClassOfType(RightTypeEl).DestType); - if (CheckClassesAreRelated(LeftTypeEl,RightTypeEl,Bin)<>cIncompatible) then + if (CheckClassesAreRelated(LeftTypeEl,RightTypeEl)<>cIncompatible) then begin SetBaseType(btBoolean); exit; @@ -10475,7 +10878,7 @@ begin if TPasClassType(LeftTypeEl).ObjKind=TPasClassType(RightTypeEl).ObjKind then begin // e.g. classinst as classtype - if (CheckSrcIsADstType(RightResolved,LeftResolved,Bin)<>cIncompatible) then + if (CheckSrcIsADstType(RightResolved,LeftResolved)<>cIncompatible) then begin SetRightValueExpr([rrfReadable]); exit; @@ -11668,12 +12071,12 @@ begin if RHS.LoTypeEl.ClassType<>TPasClassType then RaiseIncompatibleTypeRes(20170420135637,nIncompatibleTypesGotExpected, [],RHS,LHS,Right); - if CheckClassIsClass(LHS.LoTypeEl,RHS.LoTypeEl,Right) ok exit; end - else if CheckClassIsClass(RHS.LoTypeEl,LHS.LoTypeEl,Right) right is the new base class type LHS:=RHS; @@ -11696,12 +12099,12 @@ begin if RHS.LoTypeEl.ClassType<>TPasClassType then RaiseIncompatibleTypeRes(20170420091839,nIncompatibleTypesGotExpected, [],RHS,LHS,Right); - if CheckClassIsClass(LHS.LoTypeEl,RHS.LoTypeEl,Right) ok exit; end - else if CheckClassIsClass(RHS.LoTypeEl,LHS.LoTypeEl,Right) right is the new base class type LHS:=RHS; @@ -11862,9 +12265,7 @@ function TPasResolver.CheckForInClassOrRec(Loop: TPasImplForLoop; const VarResol InResolved: TPasResolverResult): boolean; var TypeEl: TPasType; - aClass, EnumeratorClass: TPasClassType; - aRecord: TPasRecordType; - ClassOrRecScope: TPasDotClassOrRecordScope; + EnumeratorClass: TPasClassType; EnumeratorScope: TPasDotClassScope; Getter, MoveNext, Current: TPasIdentifier; GetterFunc, MoveNextFunc: TPasFunction; @@ -11872,116 +12273,111 @@ var ResultResolved, MoveNextResolved, CurrentResolved: TPasResolverResult; CurrentProp: TPasProperty; ForScope: TPasForLoopScope; + DotScope: TPasDotBaseScope; begin Result:=false; + if InResolved.IdentEl is TPasType then + RaiseMsg(20190120180525,nCannotFindEnumeratorForType,sCannotFindEnumeratorForType, + [GetBaseDescription(InResolved)],Loop.StartExpr); + if not (rrfReadable in InResolved.Flags) then + RaiseMsg(20171221195421,nCannotFindEnumeratorForType,sCannotFindEnumeratorForType, + [GetBaseDescription(InResolved)],Loop.StartExpr); + TypeEl:=InResolved.LoTypeEl; - if TypeEl is TPasMembersType then + if TypeEl=nil then exit; + + // check function InVar.GetEnumerator + DotScope:=PushDotScope(TypeEl); + if DotScope=nil then + exit; + // find aRecord.GetEnumerator + Getter:=DotScope.FindIdentifier('GetEnumerator'); + PopScope; + if Getter=nil then begin - if not (rrfReadable in InResolved.Flags) then - RaiseMsg(20171221195421,nCannotFindEnumeratorForType,sCannotFindEnumeratorForType, - [GetBaseDescription(InResolved)],Loop.StartExpr); - - // check function GetEnumerator: class/record - if TypeEl is TPasClassType then - begin - aClass:=TPasClassType(TypeEl); - ClassOrRecScope:=PushClassDotScope(aClass); - end - else if TypeEl is TPasRecordType then - begin - aRecord:=TPasRecordType(TypeEl); - ClassOrRecScope:=PushRecordDotScope(aRecord); - end + if TypeEl is TPasMembersType then + RaiseIdentifierNotFound(20171221191511,'GetEnumerator',Loop.StartExpr) else - RaiseNotYetImplemented(20181228201853,Loop,GetObjName(TypeEl)); - // find aRecord.GetEnumerator - Getter:=ClassOrRecScope.FindIdentifier('GetEnumerator'); - PopScope; - if Getter=nil then - RaiseIdentifierNotFound(20171221191511,'GetEnumerator',Loop.StartExpr); - // check is function - if Getter.Element.ClassType<>TPasFunction then - RaiseContextXExpectedButYFound(20171221191638,'GetEnumerator','function',GetElementTypeName(Getter.Element),Loop.StartExpr); - GetterFunc:=TPasFunction(Getter.Element); - // check visibility - if not (GetterFunc.Visibility in [visPublic,visPublished]) then - RaiseContextXExpectedButYFound(20171221191824,'function GetEnumerator','public',VisibilityNames[GetterFunc.Visibility],Loop.StartExpr); - // check arguments - if GetterFunc.FuncType.Args.Count>0 then - RaiseContextXExpectedButYFound(20171221191944,'function GetEnumerator','no arguments',IntToStr(GetterFunc.ProcType.Args.Count),Loop.StartExpr); - // check proc type modifiers - for ptm in GetterFunc.ProcType.Modifiers do - if not (ptm in [ptmOfObject]) then - RaiseContextXInvalidY(20171221193455,'function GetEnumerator','modifier '+ProcTypeModifiers[ptm],Loop.StartExpr); - // check result type - ComputeElement(GetterFunc.FuncType.ResultEl,ResultResolved,[rcType]); - if (ResultResolved.BaseType<>btContext) then - RaiseContextXExpectedButYFound(20171221193749,'function GetEnumerator','result class',GetTypeDescription(ResultResolved),Loop.StartExpr); - TypeEl:=ResultResolved.LoTypeEl; - if not (TypeEl is TPasClassType) then - RaiseContextXExpectedButYFound(20171221193749,'function GetEnumerator','result class',GetTypeDescription(ResultResolved.LoTypeEl),Loop.StartExpr); - if not (rrfReadable in ResultResolved.Flags) then - RaiseContextXExpectedButYFound(20171221195506,'function GetEnumerator','result class instance',GetTypeDescription(ResultResolved.LoTypeEl),Loop.StartExpr); - - // find function MoveNext: boolean in Enumerator class - EnumeratorClass:=TPasClassType(TypeEl); - EnumeratorScope:=PushClassDotScope(EnumeratorClass); - MoveNext:=EnumeratorScope.FindIdentifier('MoveNext'); - if MoveNext=nil then - RaiseIdentifierNotFound(20171221195632,'MoveNext',Loop.StartExpr); - // check is function - if MoveNext.Element.ClassType<>TPasFunction then - RaiseContextXExpectedButYFound(20171221195651,'MoveNext','function',GetElementTypeName(MoveNext.Element),Loop.StartExpr); - MoveNextFunc:=TPasFunction(MoveNext.Element); - // check visibility - if not (MoveNextFunc.Visibility in [visPublic,visPublished]) then - RaiseContextXExpectedButYFound(20171221195712,'function MoveNext','public',VisibilityNames[MoveNextFunc.Visibility],Loop.StartExpr); - // check arguments - if MoveNextFunc.FuncType.Args.Count>0 then - RaiseContextXExpectedButYFound(20171221195723,'function MoveNext','no arguments',IntToStr(MoveNextFunc.ProcType.Args.Count),Loop.StartExpr); - // check proc type modifiers - for ptm in MoveNextFunc.ProcType.Modifiers do - if not (ptm in [ptmOfObject]) then - RaiseContextXInvalidY(20171221195732,'function MoveNext','modifier '+ProcTypeModifiers[ptm],Loop.StartExpr); - // check result type - ComputeElement(MoveNextFunc.FuncType.ResultEl,MoveNextResolved,[rcType]); - if not (MoveNextResolved.BaseType in btAllBooleans) then - RaiseContextXExpectedButYFound(20171221200337,'function MoveNext','result boolean',GetTypeDescription(MoveNextResolved),Loop.StartExpr); - - // check property Current - Current:=EnumeratorScope.FindIdentifier('Current'); - if Current=nil then - RaiseIdentifierNotFound(20171221200433,'Current',Loop.StartExpr); - // check is property - if Current.Element.ClassType<>TPasProperty then - RaiseContextXExpectedButYFound(20171221200508,'Current','property',GetElementTypeName(Current.Element),Loop.StartExpr); - CurrentProp:=TPasProperty(Current.Element); - // check visibility - if not (CurrentProp.Visibility in [visPublic,visPublished]) then - RaiseContextXExpectedButYFound(20171221200546,'property Current','public',VisibilityNames[CurrentProp.Visibility],Loop.StartExpr); - // check arguments - if CurrentProp.Args.Count>0 then - RaiseContextXExpectedButYFound(20171221200638,'property Current','no arguments',IntToStr(CurrentProp.Args.Count),Loop.StartExpr); - // check readable - if GetPasPropertyGetter(CurrentProp)=nil then - RaiseContextXInvalidY(20171221200823,'property Current','read accessor',Loop.StartExpr); - // check result type fits for-loop variable - ComputeElement(CurrentProp,CurrentResolved,[rcType]); - if CheckAssignResCompatibility(VarResolved,CurrentResolved,Loop.VariableName,false)=cIncompatible then - RaiseIncompatibleTypeRes(20171221200018,nIncompatibleTypesGotExpected,[],VarResolved,CurrentResolved,Loop.VariableName); - - PopScope; // pop EnumeratorScope - - ForScope:=Loop.CustomData as TPasForLoopScope; - ForScope.GetEnumerator:=GetterFunc; - ForScope.MoveNext:=MoveNextFunc; - ForScope.Current:=CurrentProp; - - exit(true); + exit; end; + // check is function + if Getter.Element.ClassType<>TPasFunction then + RaiseContextXExpectedButYFound(20171221191638,'GetEnumerator','function',GetElementTypeName(Getter.Element),Loop.StartExpr); + GetterFunc:=TPasFunction(Getter.Element); + // check visibility + if not (GetterFunc.Visibility in [visPublic,visPublished]) then + RaiseContextXExpectedButYFound(20171221191824,'function GetEnumerator','public',VisibilityNames[GetterFunc.Visibility],Loop.StartExpr); + // check arguments + if GetterFunc.FuncType.Args.Count>0 then + RaiseContextXExpectedButYFound(20171221191944,'function GetEnumerator','no arguments',IntToStr(GetterFunc.ProcType.Args.Count),Loop.StartExpr); + // check proc type modifiers + for ptm in GetterFunc.ProcType.Modifiers do + if not (ptm in [ptmOfObject]) then + RaiseContextXInvalidY(20171221193455,'function GetEnumerator','modifier '+ProcTypeModifiers[ptm],Loop.StartExpr); + // check result type + ComputeElement(GetterFunc.FuncType.ResultEl,ResultResolved,[rcType]); + if (ResultResolved.BaseType<>btContext) then + RaiseContextXExpectedButYFound(20171221193749,'function GetEnumerator','result class',GetTypeDescription(ResultResolved),Loop.StartExpr); + TypeEl:=ResultResolved.LoTypeEl; + if not (TypeEl is TPasClassType) then + RaiseContextXExpectedButYFound(20171221193749,'function GetEnumerator','result class',GetTypeDescription(ResultResolved.LoTypeEl),Loop.StartExpr); + if not (rrfReadable in ResultResolved.Flags) then + RaiseContextXExpectedButYFound(20171221195506,'function GetEnumerator','result class instance',GetTypeDescription(ResultResolved.LoTypeEl),Loop.StartExpr); - RaiseMsg(20171221192929,nCannotFindEnumeratorForType,sCannotFindEnumeratorForType, - [GetBaseDescription(InResolved)],Loop.StartExpr); + // find function MoveNext: boolean in Enumerator class + EnumeratorClass:=TPasClassType(TypeEl); + EnumeratorScope:=PushClassDotScope(EnumeratorClass); + MoveNext:=EnumeratorScope.FindIdentifier('MoveNext'); + if MoveNext=nil then + RaiseIdentifierNotFound(20171221195632,'MoveNext',Loop.StartExpr); + // check is function + if MoveNext.Element.ClassType<>TPasFunction then + RaiseContextXExpectedButYFound(20171221195651,'MoveNext','function',GetElementTypeName(MoveNext.Element),Loop.StartExpr); + MoveNextFunc:=TPasFunction(MoveNext.Element); + // check visibility + if not (MoveNextFunc.Visibility in [visPublic,visPublished]) then + RaiseContextXExpectedButYFound(20171221195712,'function MoveNext','public',VisibilityNames[MoveNextFunc.Visibility],Loop.StartExpr); + // check arguments + if MoveNextFunc.FuncType.Args.Count>0 then + RaiseContextXExpectedButYFound(20171221195723,'function MoveNext','no arguments',IntToStr(MoveNextFunc.ProcType.Args.Count),Loop.StartExpr); + // check proc type modifiers + for ptm in MoveNextFunc.ProcType.Modifiers do + if not (ptm in [ptmOfObject]) then + RaiseContextXInvalidY(20171221195732,'function MoveNext','modifier '+ProcTypeModifiers[ptm],Loop.StartExpr); + // check result type + ComputeElement(MoveNextFunc.FuncType.ResultEl,MoveNextResolved,[rcType]); + if not (MoveNextResolved.BaseType in btAllBooleans) then + RaiseContextXExpectedButYFound(20171221200337,'function MoveNext','result boolean',GetTypeDescription(MoveNextResolved),Loop.StartExpr); + + // check property Current + Current:=EnumeratorScope.FindIdentifier('Current'); + if Current=nil then + RaiseIdentifierNotFound(20171221200433,'Current',Loop.StartExpr); + // check is property + if Current.Element.ClassType<>TPasProperty then + RaiseContextXExpectedButYFound(20171221200508,'Current','property',GetElementTypeName(Current.Element),Loop.StartExpr); + CurrentProp:=TPasProperty(Current.Element); + // check visibility + if not (CurrentProp.Visibility in [visPublic,visPublished]) then + RaiseContextXExpectedButYFound(20171221200546,'property Current','public',VisibilityNames[CurrentProp.Visibility],Loop.StartExpr); + // check arguments + if CurrentProp.Args.Count>0 then + RaiseContextXExpectedButYFound(20171221200638,'property Current','no arguments',IntToStr(CurrentProp.Args.Count),Loop.StartExpr); + // check readable + if GetPasPropertyGetter(CurrentProp)=nil then + RaiseContextXInvalidY(20171221200823,'property Current','read accessor',Loop.StartExpr); + // check result type fits for-loop variable + ComputeElement(CurrentProp,CurrentResolved,[rcType]); + if CheckAssignResCompatibility(VarResolved,CurrentResolved,Loop.VariableName,false)=cIncompatible then + RaiseIncompatibleTypeRes(20171221200018,nIncompatibleTypesGotExpected,[],VarResolved,CurrentResolved,Loop.VariableName); + + PopScope; // pop EnumeratorScope + + ForScope:=Loop.CustomData as TPasForLoopScope; + ForScope.GetEnumerator:=GetterFunc; + ForScope.MoveNext:=MoveNextFunc; + ForScope.Current:=CurrentProp; + Result:=true; end; function TPasResolver.CheckBuiltInMinParamCount(Proc: TResElDataBuiltInProc; @@ -14876,6 +15272,7 @@ var CurSection: TPasSection; i: Integer; UsesUnit: TPasUsesUnit; + CurScope: TPasDotBaseScope; begin Result:=nil; //writeln('TPasResolver.FindElement Name="',aName,'"'); @@ -14914,10 +15311,13 @@ begin if CurScopeEl<>nil then begin NeedPop:=true; - if CurScopeEl.ClassType=TPasClassType then - PushClassDotScope(TPasClassType(CurScopeEl)) - else if CurScopeEl.ClassType=TPasRecordType then - PushRecordDotScope(TPasRecordType(CurScopeEl)) + if CurScopeEl is TPasType then + begin + CurScope:=PushDotScope(TPasType(CurScopeEl)); + if CurScope=nil then + RaiseMsg(20190122122529,nIllegalQualifierAfter,sIllegalQualifierAfter, + ['.',LeftPath],ErrorEl); + end else if CurScopeEl is TPasModule then PushModuleDotScope(TPasModule(CurScopeEl)) else @@ -15023,14 +15423,14 @@ begin Abort:=false; Data:=Default(TPRFindData); Data.ErrorPosEl:=ErrorPosEl; - IterateElements(AName,@OnFindFirstElement,@Data,Abort); + IterateElements(AName,@OnFindFirst_PreferNoParams,@Data,Abort); Result:=Data.Found; if Result=nil then begin if (ErrorPosEl=nil) and (LastElement<>nil) then begin if (LastElement.ClassType=TPasClassOfType) - and (TPasClassOfType(LastElement).DestType=nil) then + and (TPasClassOfType(LastElement).DestType=nil) then begin // 'class of' of a not yet defined class Result:=CreateElement(TUnresolvedPendingRef,AName,LastElement,visDefault, @@ -15038,7 +15438,7 @@ begin exit; end else if (LastElement.ClassType=TPasPointerType) - and (TPasPointerType(LastElement).DestType=nil) then + and (TPasPointerType(LastElement).DestType=nil) then begin // pointer of a not yet defined type Result:=CreateElement(TUnresolvedPendingRef,AName,LastElement,visDefault, @@ -15056,6 +15456,18 @@ begin sWrongNumberOfParametersForCallTo,[GetProcTypeDescription(TPasProcedure(Result).ProcType)],ErrorPosEl); end; +function TPasResolver.FindFirstEl(const AName: String; out Data: TPRFindData; + ErrorPosEl: TPasElement): TPasElement; +var + Abort: boolean; +begin + Abort:=false; + Data:=Default(TPRFindData); + Data.ErrorPosEl:=ErrorPosEl; + IterateElements(AName,@OnFindFirst,@Data,Abort); + Result:=Data.Found; +end; + procedure TPasResolver.FindLongestUnitName(var El: TPasElement; Expr: TPasExpr); // Input: El is TPasUsesUnit // Output: El is either a TPasUsesUnit or the root module @@ -15170,8 +15582,6 @@ procedure TPasResolver.CheckFoundElement( var Proc: TPasProcedure; - Context: TPasElement; - FoundContext: TPasMembersType; StartScope: TPasScope; OnlyTypeMembers, IsClassOf: Boolean; TypeEl: TPasType; @@ -15183,15 +15593,15 @@ begin StartScope:=FindData.StartScope; OnlyTypeMembers:=false; IsClassOf:=false; - if StartScope is TPasDotIdentifierScope then + if StartScope is TPasDotBaseScope then begin - OnlyTypeMembers:=TPasDotIdentifierScope(StartScope).OnlyTypeMembers; + OnlyTypeMembers:=TPasDotBaseScope(StartScope).OnlyTypeMembers; if StartScope.ClassType=TPasDotClassScope then IsClassOf:=TPasDotClassScope(StartScope).IsClassOf; if Ref<>nil then begin Include(Ref.Flags,rrfDotScope); - if TPasDotIdentifierScope(StartScope).ConstParent + if TPasDotBaseScope(StartScope).ConstParent and IsFieldInheritingConst(Ref) then Include(Ref.Flags,rrfConstInherited); end; @@ -15217,16 +15627,16 @@ begin end; //writeln('TPasResolver.CheckFoundElOnStartScope StartScope=',StartScope.ClassName, - // ' StartIsDot=',StartScope is TPasDotIdentifierScope, - // ' OnlyTypeMembers=',(StartScope is TPasDotIdentifierScope) - // and TPasDotIdentifierScope(StartScope).OnlyTypeMembers, + // ' StartIsDot=',StartScope is TPasDotBaseScope, + // ' OnlyTypeMembers=',(StartScope is TPasDotBaseScope) + // and TPasDotBaseScope(StartScope).OnlyTypeMembers, // ' FindData.Found=',GetObjName(FindData.Found)); if OnlyTypeMembers then begin //writeln('TPasResolver.CheckFoundElOnStartScope ',GetObjName(FindData.Found),' ',(FindData.Found is TPasVariable) // and (vmClass in TPasVariable(FindData.Found).VarModifiers)); // only class vars/procs allowed - if (FindData.Found.ClassType=TPasConstructor) then + if FindData.Found.ClassType=TPasConstructor then // constructor: ok else if IsClassMethod(FindData.Found) then @@ -15234,8 +15644,10 @@ begin else if (FindData.Found is TPasVariable) and (vmClass in TPasVariable(FindData.Found).VarModifiers) then // class var/const/property: ok - else if (FindData.Found is TPasType) then - // local type: ok + else if FindData.Found is TPasType then + // nested type: ok + else if FindData.Found is TPasEnumValue then + // e.g. enumtype.enumvalue: ok else begin RaiseMsg(20170216152348,nCannotAccessThisMemberFromAX, @@ -15243,16 +15655,16 @@ begin end; end else if (proExtClassInstanceNoTypeMembers in Options) - and (StartScope.ClassType=TPasDotClassScope) - and TPasClassType(TPasDotClassScope(StartScope).ClassScope.Element).IsExternal then + and (StartScope is TPasDotClassScope) + and TPasClassType(TPasDotClassScope(StartScope).ClassRecScope.Element).IsExternal then begin - // found member in external class instance + // e.g. ExtClassInstance.Member C:=FindData.Found.ClassType; if (C=TPasProcedure) or (C=TPasFunction) then // ok else if (C=TPasConst) then // ok - else if C.InheritsFrom(TPasVariable) + else if ((C=TPasVariable) or (C=TPasProperty)) and (not (vmClass in TPasVariable(FindData.Found).VarModifiers)) then // ok else @@ -15269,10 +15681,9 @@ begin Proc:=TPasProcedure(FindData.Found); if Proc.IsVirtual or Proc.IsOverride then begin - if (StartScope.ClassType=TPasDotClassScope) - and TPasDotClassScope(StartScope).InheritedExpr then + if StartScope.ClassType=TPasInheritedScope then begin - // call directly + // inherited expr -> call directly if Proc.IsAbstract then RaiseMsg(20170216152352,nAbstractMethodsCannotBeCalledDirectly, sAbstractMethodsCannotBeCalledDirectly,[],FindData.ErrorPosEl); @@ -15296,15 +15707,17 @@ begin if Ref.Context<>nil then RaiseInternalError(20170131141936); Ref.Context:=TResolvedRefCtxConstructor.Create; - if StartScope is TPasDotClassOrRecordScope then - ClassRecScope:=TPasClassOrRecordScope(TPasDotClassOrRecordScope(StartScope).IdentifierScope) - else if (StartScope is TPasWithExprScope) - and (TPasWithExprScope(StartScope).Scope is TPasClassOrRecordScope) then - ClassRecScope:=TPasClassOrRecordScope(TPasWithExprScope(StartScope).Scope) - else if (StartScope is TPasProcedureScope) then - ClassRecScope:=TPasProcedureScope(StartScope).ClassOrRecordScope + C:=StartScope.ClassType; + if C.InheritsFrom(TPasDotClassOrRecordScope) then + ClassRecScope:=TPasDotClassOrRecordScope(StartScope).ClassRecScope + else if C.InheritsFrom(TPasWithExprScope) then + ClassRecScope:=TPasWithExprScope(StartScope).ClassRecScope + else if C.InheritsFrom(TPasProcedureScope) then + ClassRecScope:=TPasProcedureScope(StartScope).ClassRecScope else RaiseInternalError(20170131150855,GetObjName(StartScope)); + if ClassRecScope=nil then + RaiseInternalError(20190123120156,GetObjName(StartScope)); TypeEl:=ClassRecScope.Element as TPasType; TResolvedRefCtxConstructor(Ref.Context).Typ:=TypeEl; if OnlyTypeMembers and (ClassRecScope is TPasClassScope) then @@ -15343,8 +15756,7 @@ begin // destructor: FreeInstance or normal call // it is a normal call if 'inherited' if (Proc.ClassType=TPasDestructor) and (Ref<>nil) then - if ((StartScope.ClassType<>TPasDotClassScope) - or (not TPasDotClassScope(StartScope).InheritedExpr)) then + if not (StartScope is TPasInheritedScope) then Ref.Flags:=Ref.Flags+[rrfFreeInstance]; {$IFDEF VerbosePasResolver} {AllowWriteln} @@ -15357,8 +15769,8 @@ begin begin write(' rrfFreeInstance=',rrfFreeInstance in Ref.Flags, ' StartScope=',GetObjName(StartScope)); - if StartScope.ClassType=TPasDotClassScope then - write(' InheritedExpr=',TPasDotClassScope(StartScope).InheritedExpr); + if StartScope is TPasDotClassOrRecordScope then + write(' InheritedExpr=',StartScope is TPasInheritedScope); end; writeln; end; @@ -15366,6 +15778,19 @@ begin {$ENDIF} end; + CheckFoundElementVisibility(FindData,Ref); +end; + +procedure TPasResolver.CheckFoundElementVisibility(const FindData: TPRFindData; + Ref: TResolvedReference); +var + Context: TPasElement; + FoundContext: TPasMembersType; + CurScope: TPasScope; + {$IFDEF VerbosePasResolver} + i: Integer; + {$ENDIF} +begin // check class visibility if FindData.Found.Visibility in [visPrivate,visProtected,visStrictPrivate,visStrictProtected] then begin @@ -15375,41 +15800,54 @@ begin visPrivate: // private members can only be accessed in same module if FoundContext.GetModule<>Context.GetModule then - RaiseMsg(20170216152354,nCantAccessPrivateMember,sCantAccessPrivateMember, + RaiseMsg(20170216152354,nCantAccessXMember,sCantAccessXMember, ['private',FindData.Found.Name],FindData.ErrorPosEl); visProtected: + begin // protected members can only be accessed in same module - // or modules of descendant classes + // or descendant classes + CurScope:=TopScope; if FoundContext.GetModule=Context.GetModule then // same module -> ok else if (Context is TPasType) - and (CheckClassIsClass(TPasType(Context),FoundContext,FindData.ErrorPosEl)<>cIncompatible) then + and (CheckClassIsClass(TPasType(Context),FoundContext)<>cIncompatible) then // context in class or descendant - else if (TopScope is TPasDotClassScope) - and (TPasDotClassScope(TopScope).ClassScope.Element.GetModule=Context.GetModule) then + else if (CurScope is TPasDotClassOrRecordScope) + and (TPasDotClassOrRecordScope(CurScope).ClassRecScope.Element.GetModule=Context.GetModule) then // e.g. aClassInThisModule.identifier - else if (TopScope is TPasWithExprScope) - and (TPasWithExprScope(TopScope).Scope is TPasClassScope) - and (TPasClassScope(TPasWithExprScope(TopScope).Scope).Element.GetModule=Context.GetModule) then + else if (CurScope is TPasWithExprScope) + and (TPasWithExprScope(CurScope).Scope.Element<>nil) + and (TPasWithExprScope(CurScope).Scope.Element.GetModule=Context.GetModule) then // e.g. with aClassInThisModule do identifier else - RaiseMsg(20170216152356,nCantAccessPrivateMember,sCantAccessPrivateMember, + RaiseMsg(20170216152356,nCantAccessXMember,sCantAccessXMember, ['protected',FindData.Found.Name],FindData.ErrorPosEl); + end; visStrictPrivate: // strict private members can only be accessed in their class if Context<>FoundContext then - RaiseMsg(20170216152357,nCantAccessPrivateMember,sCantAccessPrivateMember, + begin + {$IFDEF VerbosePasResolver} + {AllowWriteln} + writeln('TPasResolver.CheckFoundElement Context=',GetElementDbgPath(Context),' FoundContext=',GetElementDbgPath(FoundContext)); + for i:=ScopeCount-1 downto 0 do + writeln(' ',i,' ',Scopes[i].ClassName,' Element=',GetObjName(Scopes[i].Element),' VisibilityContext=',GetObjName(Scopes[i].VisibilityContext)); + {AllowWriteln-} + {$ENDIF} + RaiseMsg(20170216152357,nCantAccessXMember,sCantAccessXMember, ['strict private',FindData.Found.Name],FindData.ErrorPosEl); + end; visStrictProtected: // strict protected members can only be accessed in their and descendant classes if (Context is TPasType) - and (CheckClassIsClass(TPasType(Context),FoundContext,FindData.ErrorPosEl)<>cIncompatible) then + and (CheckClassIsClass(TPasType(Context),FoundContext)<>cIncompatible) then // context in class or descendant else - RaiseMsg(20170216152400,nCantAccessPrivateMember,sCantAccessPrivateMember, + RaiseMsg(20170216152400,nCantAccessXMember,sCantAccessXMember, ['strict protected',FindData.Found.Name],FindData.ErrorPosEl); end; end; + if Ref=nil then ; end; function TPasResolver.GetVisibilityContext: TPasElement; @@ -15461,6 +15899,7 @@ var AncestorClass, aClass: TPasClassType; Scope: TPasIdentifierScope; OldType: TPasTypeAliasType; + LocalScope: TPasScope; begin DestType:=TPasTypeAliasType(NewType).DestType; TypeEl:=ResolveSimpleAliasType(DestType); @@ -15471,7 +15910,8 @@ begin AncestorClass := TPasClassType(TypeEl); // remove aliastype from scope - Scope:=TopScope as TPasIdentifierScope; + LocalScope:=GetLocalScope; + Scope:=LocalScope as TPasIdentifierScope; Scope.RemoveLocalIdentifier(NewType); // create class or interface @@ -15722,6 +16162,7 @@ end; procedure TPasResolver.Clear; begin + ClearHelperList(FActiveHelpers); RestoreSubExprScopes(0); // clear stack, keep DefaultScope while (FScopeCount>0) and (FTopScope<>DefaultScope) do @@ -15987,6 +16428,20 @@ begin EmitElementHints(RefEl,DeclEl); end; +function TPasResolver.GetLocalScope: TPasScope; +begin + Result:=TopScope; + if Result.ClassType=TPasGroupScope then + Result:=TPasGroupScope(Result).Scopes[0]; +end; + +function TPasResolver.GetParentLocalScope: TPasScope; +begin + Result:=Scopes[ScopeCount-2]; + if Result.ClassType=TPasGroupScope then + Result:=TPasGroupScope(Result).Scopes[0]; +end; + function TPasResolver.CreateScope(El: TPasElement; ScopeClass: TPasScopeClass ): TPasScope; begin @@ -16010,6 +16465,76 @@ begin AddResolveData(El,Result,lkModule); end; +function TPasResolver.CreateGroupScope(aType: TPasType; WithTopHelpers: boolean + ): TPasGroupScope; +begin + Result:=TPasGroupScope.Create; + Result.Element:=aType; + GroupScope_AddTypeAndAncestors(Result,aType,WithTopHelpers); +end; + +procedure TPasResolver.GroupScope_AddTypeAndAncestors(Scope: TPasGroupScope; + TypeEl: TPasType; WithTopHelpers: boolean); +var + IsClass: Boolean; + i: Integer; + Entry: TPRHelperEntry; + HelperForType: TPasType; + AncestorScope, HelperScope: TPasClassScope; + C: TClass; +begin + IsClass:=TypeEl.ClassType=TPasClassType; + if IsClass and (TPasClassType(TypeEl).HelperForType<>nil) then + begin + // start in a helper + WithTopHelpers:=false; + // first add helper and its ancestors + HelperScope:=TPasClassScope(TypeEl.CustomData); + while HelperScope<>nil do + begin + Scope.Add(HelperScope); + HelperScope:=HelperScope.AncestorScope; + end; + // then add the HelperForType and its ancestors + TypeEl:=ResolveAliasType(TPasClassType(TypeEl).HelperForType); + IsClass:=TypeEl.ClassType=TPasClassType; + end; + repeat + // first add helper(s) + if WithTopHelpers then + begin + for i:=length(FActiveHelpers)-1 downto 0 do + begin + Entry:=FActiveHelpers[i]; + HelperForType:=Entry.HelperForType; + if HelperForType=TypeEl then + begin + // add Helper and its ancestors + HelperScope:=TPasClassScope(Entry.Helper.CustomData); + while HelperScope<>nil do + begin + Scope.Add(HelperScope); + HelperScope:=HelperScope.AncestorScope; + end; + if not (msMultipleScopeHelpers in CurrentParser.CurrentModeswitches) then + break; + end; + end; + end + else + WithTopHelpers:=true; + // then add scope of TypeEl + C:=TypeEl.ClassType; + if (C=TPasClassType) or (C=TPasRecordType) then + Scope.Add(TypeEl.CustomData as TPasIdentifierScope); + // continue with ancestor + if not IsClass then break; + AncestorScope:=(TypeEl.CustomData as TPasClassScope).AncestorScope; + if AncestorScope=nil then break; + TypeEl:=TPasClassType(AncestorScope.Element); + until TypeEl=nil; +end; + procedure TPasResolver.PopScope; var Scope: TPasScope; @@ -16077,6 +16602,12 @@ begin PushScope(Result); end; +function TPasResolver.PushGroupScope(aType: TPasType): TPasGroupScope; +begin + Result:=CreateGroupScope(aType); + PushScope(Result); +end; + function TPasResolver.PushModuleDotScope(aModule: TPasModule): TPasModuleDotScope; begin Result:=TPasModuleDotScope.Create; @@ -16111,8 +16642,8 @@ begin PushScope(Result); end; -function TPasResolver.PushClassDotScope(var CurClassType: TPasClassType - ): TPasDotClassScope; +function TPasResolver.PushClassDotScope(var CurClassType: TPasClassType; + WithTopHelpers: boolean): TPasDotClassScope; var ClassScope: TPasClassScope; Ref: TResolvedReference; @@ -16127,34 +16658,75 @@ begin ClassScope:=NoNil(CurClassType.CustomData) as TPasClassScope; Result:=TPasDotClassScope.Create; Result.Owner:=Self; - Result.ClassScope:=ClassScope; + Result.ClassRecScope:=ClassScope; + Result.GroupScope:=CreateGroupScope(CurClassType,WithTopHelpers); PushScope(Result); end; -function TPasResolver.PushRecordDotScope(CurRecordType: TPasRecordType - ): TPasDotRecordScope; +function TPasResolver.PushRecordDotScope(CurRecordType: TPasRecordType): TPasDotClassOrRecordScope; var RecScope: TPasRecordScope; begin RecScope:=NoNil(CurRecordType.CustomData) as TPasRecordScope; - Result:=TPasDotRecordScope.Create; + Result:=TPasDotClassOrRecordScope.Create; Result.Owner:=Self; - Result.IdentifierScope:=RecScope; + Result.ClassRecScope:=RecScope; + Result.GroupScope:=CreateGroupScope(CurRecordType); + PushScope(Result); +end; + +function TPasResolver.PushInheritedScope(ClassOrRec: TPasMembersType; + WithTopHelpers: boolean; AncestorScope: TPasClassScope): TPasInheritedScope; +begin + Result:=TPasInheritedScope.Create; + Result.Owner:=Self; + Result.ClassRecScope:=NoNil(ClassOrRec.CustomData) as TPasClassOrRecordScope; + Result.AncestorScope:=AncestorScope; + Result.GroupScope:=CreateGroupScope(ClassOrRec,WithTopHelpers); PushScope(Result); end; function TPasResolver.PushEnumDotScope(CurEnumType: TPasEnumType ): TPasDotEnumTypeScope; -var - EnumScope: TPasEnumTypeScope; begin - EnumScope:=NoNil(CurEnumType.CustomData) as TPasEnumTypeScope; Result:=TPasDotEnumTypeScope.Create; Result.Owner:=Self; - Result.IdentifierScope:=EnumScope; + Result.EnumScope:=NoNil(CurEnumType.CustomData) as TPasEnumTypeScope; + Result.GroupScope:=CreateGroupScope(CurEnumType); PushScope(Result); end; +function TPasResolver.PushHelperDotScope(TypeEl: TPasType): TPasDotBaseScope; +var + Group: TPasGroupScope; +begin + Group:=CreateGroupScope(TypeEl); + if Group.Count=0 then + begin + Group.Free; + exit(nil); + end; + Result:=TPasDotBaseScope.Create; + Result.Owner:=Self; + Result.GroupScope:=Group; + PushScope(Result); +end; + +function TPasResolver.PushDotScope(TypeEl: TPasType): TPasDotBaseScope; +var + C: TClass; +begin + C:=TypeEl.ClassType; + if C=TPasClassType then + Result:=PushClassDotScope(TPasClassType(TypeEl)) + else if C=TPasRecordType then + Result:=PushRecordDotScope(TPasRecordType(TypeEl)) + else if C=TPasEnumType then + Result:=PushEnumDotScope(TPasEnumType(TypeEl)) + else + Result:=PushHelperDotScope(TypeEl); +end; + function TPasResolver.PushWithExprScope(Expr: TPasExpr): TPasWithExprScope; var WithEl: TPasImplWithDo; @@ -16162,10 +16734,11 @@ var ExprResolved: TPasResolverResult; ErrorEl: TPasExpr; TypeEl: TPasType; - OnlyTypeMembers, IsClassOf: Boolean; - ExprScope: TPasIdentifierScope; + ExprScope: TPasGroupScope; ClassEl: TPasClassType; WithExprScope: TPasWithExprScope; + Flags: TPasWithExprScopeFlags; + ClassRecScope: TPasClassOrRecordScope; begin if not (Expr.Parent is TPasImplWithDo) then RaiseInternalError(20181210163412,GetObjName(Expr.Parent)); @@ -16186,48 +16759,48 @@ begin RaiseMsg(20170216152004,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot, [BaseTypeNames[ExprResolved.BaseType]],ErrorEl); - OnlyTypeMembers:=false; - IsClassOf:=false; - if TypeEl.ClassType=TPasRecordType then - begin - ExprScope:=NoNil(TPasRecordType(TypeEl).CustomData) as TPasRecordScope; - if ExprResolved.IdentEl is TPasType then - // e.g. with TPoint do PointInCircle - OnlyTypeMembers:=true; - end - else if TypeEl.ClassType=TPasClassType then - begin - ExprScope:=NoNil(TPasClassType(TypeEl).CustomData) as TPasClassScope; - if ExprResolved.IdentEl is TPasType then - // e.g. with TFPMemoryImage do FindHandlerFromExtension() - OnlyTypeMembers:=true; - end - else if TypeEl.ClassType=TPasClassOfType then + Flags:=[]; + CheckUseAsType(TypeEl,20190123113957,Expr); + ClassRecScope:=nil; + ExprScope:=nil; + if TypeEl.ClassType=TPasClassOfType then begin // e.g. with ImageClass do FindHandlerFromExtension() ClassEl:=ResolveAliasType(TPasClassOfType(TypeEl).DestType) as TPasClassType; - ExprScope:=ClassEl.CustomData as TPasClassScope; - OnlyTypeMembers:=true; - IsClassOf:=true; + ExprScope:=CreateGroupScope(ClassEl); + ClassRecScope:=TPasClassOrRecordScope(ClassEl.CustomData); + Include(Flags,wesfOnlyTypeMembers); + Include(Flags,wesfIsClassOf); end - else - RaiseMsg(20170216152007,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot, - [GetElementTypeName(TypeEl)],ErrorEl); + else if TypeEl is TPasMembersType then + ClassRecScope:=TPasClassOrRecordScope(TypeEl.CustomData); + + if ExprScope=nil then + begin + ExprScope:=CreateGroupScope(TypeEl); + if ExprScope.Count=0 then + begin + ExprScope.Free; + RaiseMsg(20170216152007,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot, + [GetElementTypeName(TypeEl)],ErrorEl); + end; + if ExprResolved.IdentEl is TPasType then + // e.g. with TPoint do PointInCircle + Include(Flags,wesfOnlyTypeMembers); + end; WithExprScope:=ScopeClass_WithExpr.Create; WithExprScope.WithScope:=WithScope; WithExprScope.Index:=WithEl.Expressions.Count; WithExprScope.Expr:=Expr; WithExprScope.Scope:=ExprScope; + WithExprScope.ClassRecScope:=ClassRecScope; if not (ExprResolved.IdentEl is TPasType) then - Include(WithExprScope.Flags,wesfNeedTmpVar); - if OnlyTypeMembers then - Include(WithExprScope.Flags,wesfOnlyTypeMembers); - if IsClassOf then - Include(WithExprScope.Flags,wesfIsClassOf); + Include(Flags,wesfNeedTmpVar); if (not (rrfWritable in ExprResolved.Flags)) and (ExprResolved.BaseType=btContext) and (ExprResolved.LoTypeEl.ClassType=TPasRecordType) then - Include(WithExprScope.Flags,wesfConstParent); + Include(Flags,wesfConstParent); + WithExprScope.Flags:=Flags; WithScope.ExpressionScopes.Add(WithExprScope); PushScope(WithExprScope); Result:=WithExprScope; @@ -16273,7 +16846,7 @@ begin end; end; -function TPasResolver.GetInheritedExprScope(ErrorEl: TPasElement +function TPasResolver.GetProcScope(ErrorEl: TPasElement ): TPasProcedureScope; var Scope: TPasScope; @@ -16291,6 +16864,56 @@ begin Result:=nil; end; +function TPasResolver.GetSelfScope(ErrorEl: TPasElement): TPasProcedureScope; +begin + Result:=GetProcScope(ErrorEl); + Result:=Result.GetSelfScope; +end; + +procedure TPasResolver.AddHelper(Helper: TPasClassType; + var List: TPRHelperEntryArray); + {$IF defined(fpc) and (FPC_FULLVERSION<30101)} + procedure Insert(Item: TPRHelperEntry; var A: TPRHelperEntryArray; Index: integer); overload; + var + i: Integer; + begin + if Index<0 then + RaiseInternalError(20190118211455); + if Index>length(A) then + RaiseInternalError(20190119122624); + SetLength(A,length(A)+1); + for i:=length(A)-1 downto Index+1 do + A[i]:=A[i-1]; + A[Index]:=Item; + end; + {$ENDIF} +var + NewEntry, Entry: TPRHelperEntry; + i: Integer; + HelperForType: TPasType; +begin + HelperForType:=ResolveAliasType(Helper.HelperForType); + NewEntry:=TPRHelperEntry.Create; + NewEntry.Helper:=Helper; + NewEntry.HelperForType:=HelperForType; + NewEntry.Added:=length(List); + // keep list sorted for 1. HelperForType and 2. Added + for i:=0 to length(List)-1 do + begin + Entry:=List[i]; + if ComparePRHelperEntries(NewEntry,Entry)<=0 then continue; + Insert(NewEntry,List,i); + exit; + end; + // append + Insert(NewEntry,List,length(List)); +end; + +procedure TPasResolver.AddActiveHelper(Helper: TPasClassType); +begin + AddHelper(Helper,FActiveHelpers); +end; + class function TPasResolver.MangleSourceLineNumber(Line, Column: integer ): integer; begin @@ -16522,6 +17145,12 @@ begin RaiseIncompatibleTypeDesc(id,MsgNumber,Args,GotDesc,ExpDesc,ErrorEl); end; +procedure TPasResolver.RaiseHelpersCannotBeUsedAsType(id: TMaxPrecInt; + ErrorEl: TPasElement); +begin + RaiseMsg(id,nHelpersCannotBeUsedAsTypes,sHelpersCannotBeUsedAsTypes,[],ErrorEl); +end; + procedure TPasResolver.RaiseInvalidProcTypeModifier(id: TMaxPrecInt; ProcType: TPasProcedureType; ptm: TProcTypeModifier; ErrorEl: TPasElement); begin @@ -19010,7 +19639,7 @@ begin if not (rrfReadable in RHS.Flags) then exit(RaiseIncompatType); if TPasClassType(LTypeEl).ObjKind=TPasClassType(RTypeEl).ObjKind then - Result:=CheckSrcIsADstType(RHS,LHS,ErrorEl) + Result:=CheckSrcIsADstType(RHS,LHS) else if TPasClassType(LTypeEl).ObjKind=okInterface then begin if (TPasClassType(RTypeEl).ObjKind=okClass) @@ -19051,7 +19680,7 @@ begin begin // e.g. ImageClass:=AnotherImageClass; Result:=CheckClassIsClass(TPasClassOfType(RTypeEl).DestType, - TPasClassOfType(LTypeEl).DestType,ErrorEl); + TPasClassOfType(LTypeEl).DestType); if (Result=cIncompatible) and RaiseOnIncompatible then RaiseMsg(20170216152500,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected, ['class of '+TPasClassOfType(RTypeEl).DestType.PathName,'class of '+TPasClassOfType(LTypeEl).DestType.PathName],ErrorEl); @@ -19061,7 +19690,7 @@ begin and (ResolveAliasType(TPasType(RHS.IdentEl)).ClassType=TPasClassType) then begin // e.g. ImageClass:=TFPMemoryImage; - Result:=CheckClassIsClass(RTypeEl,TPasClassOfType(LTypeEl).DestType,ErrorEl); + Result:=CheckClassIsClass(RTypeEl,TPasClassOfType(LTypeEl).DestType); if (Result=cIncompatible) and RaiseOnIncompatible then RaiseMsg(20170216152501,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected, [RTypeEl.Name,'class of '+TPasClassOfType(LTypeEl).DestType.PathName],ErrorEl); @@ -19667,9 +20296,9 @@ begin if RTypeEl.ClassType=TPasClassType then begin // e.g. if Sender=Button1 then - Result:=CheckSrcIsADstType(LHS,RHS,ErrorEl); + Result:=CheckSrcIsADstType(LHS,RHS); if Result=cIncompatible then - Result:=CheckSrcIsADstType(RHS,LHS,ErrorEl); + Result:=CheckSrcIsADstType(RHS,LHS); if (Result=cIncompatible) and RaiseOnIncompatible then RaiseIncompatibleTypeRes(20180324190757,nTypesAreNotRelatedXY,[],LHS,RHS,ErrorEl); exit; @@ -19689,10 +20318,10 @@ begin begin // for example: if ImageClass=ImageClass then Result:=CheckClassIsClass(TPasClassOfType(LTypeEl).DestType, - TPasClassOfType(RTypeEl).DestType,ErrorEl); + TPasClassOfType(RTypeEl).DestType); if Result=cIncompatible then Result:=CheckClassIsClass(TPasClassOfType(RTypeEl).DestType, - TPasClassOfType(LTypeEl).DestType,ErrorEl); + TPasClassOfType(LTypeEl).DestType); if (Result=cIncompatible) and RaiseOnIncompatible then RaiseIncompatibleTypeRes(20180324190804,nTypesAreNotRelatedXY,[],LHS,RHS,ErrorEl); exit; @@ -19921,9 +20550,9 @@ begin if TPasClassType(FromTypeEl).ObjKind=TPasClassType(ToTypeEl).ObjKind then begin // type cast upwards or downwards - Result:=CheckSrcIsADstType(FromResolved,ToResolved,ErrorEl); + Result:=CheckSrcIsADstType(FromResolved,ToResolved); if Result=cIncompatible then - Result:=CheckSrcIsADstType(ToResolved,FromResolved,ErrorEl); + Result:=CheckSrcIsADstType(ToResolved,FromResolved); end else if TPasClassType(ToTypeEl).ObjKind=okInterface then begin @@ -19965,7 +20594,7 @@ begin // type cast classof(classof-var) upwards or downwards ToClassType:=TPasClassOfType(ToTypeEl).DestType; FromClassType:=TPasClassOfType(FromResolved.LoTypeEl).DestType; - Result:=CheckClassesAreRelated(ToClassType,FromClassType,ErrorEl); + Result:=CheckClassesAreRelated(ToClassType,FromClassType); end; end else if FromResolved.BaseType=btPointer then @@ -20142,7 +20771,7 @@ begin // for example class-of(Self) in a class function ToClassType:=TPasClassOfType(ToTypeEl).DestType; FromClassType:=TPasClassType(FromTypeEl); - Result:=CheckClassesAreRelated(ToClassType,FromClassType,ErrorEl); + Result:=CheckClassesAreRelated(ToClassType,FromClassType); end; end; end; @@ -20839,6 +21468,15 @@ begin Result:=false; end; +procedure TPasResolver.CheckUseAsType(aType: TPasElement; id: TMaxPrecInt; + ErrorEl: TPasElement); +begin + if aType=nil then exit; + if aType.ClassType<>TPasClassType then exit; + if TPasClassType(aType).HelperForType<>nil then + RaiseHelpersCannotBeUsedAsType(id,ErrorEl); +end; + function TPasResolver.GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType; var @@ -21874,14 +22512,13 @@ begin end; function TPasResolver.CheckSrcIsADstType(const ResolvedSrcType, - ResolvedDestType: TPasResolverResult; ErrorEl: TPasElement): integer; + ResolvedDestType: TPasResolverResult): integer; // finds distance between classes SrcType and DestType begin - Result:=CheckClassIsClass(ResolvedSrcType.LoTypeEl,ResolvedDestType.LoTypeEl,ErrorEl); + Result:=CheckClassIsClass(ResolvedSrcType.LoTypeEl,ResolvedDestType.LoTypeEl); end; -function TPasResolver.CheckClassIsClass(SrcType, DestType: TPasType; - ErrorEl: TPasElement): integer; +function TPasResolver.CheckClassIsClass(SrcType, DestType: TPasType): integer; // check if Src is equal or descends from Dest var ClassEl: TPasClassType; @@ -21905,7 +22542,7 @@ begin SrcType:=TPasAliasType(SrcType).DestType else if SrcType.ClassType=TPasTypeAliasType then begin - // type alias -> increases distance + // type alias -> increase distance SrcType:=TPasAliasType(SrcType).DestType; inc(Result); end @@ -21925,16 +22562,14 @@ begin else exit(cIncompatible); end; - if ErrorEl=nil then ; Result:=cIncompatible; end; -function TPasResolver.CheckClassesAreRelated(TypeA, TypeB: TPasType; - ErrorEl: TPasElement): integer; +function TPasResolver.CheckClassesAreRelated(TypeA, TypeB: TPasType): integer; begin - Result:=CheckClassIsClass(TypeA,TypeB,ErrorEl); + Result:=CheckClassIsClass(TypeA,TypeB); if Result<>cIncompatible then exit; - Result:=CheckClassIsClass(TypeB,TypeA,ErrorEl); + Result:=CheckClassIsClass(TypeB,TypeA); end; function TPasResolver.GetClassImplementsIntf(ClassEl, Intf: TPasClassType diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index 73a13d8ca7..b32ed1236f 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -741,6 +741,12 @@ type // okSpecialize removed in FPC 3.1.1 okClassHelper,okRecordHelper,okTypeHelper, okDispInterface); +const + okWithFields = [okObject, okClass, okGeneric]; + okAllHelpers = [okClassHelper,okRecordHelper,okTypeHelper]; + okWithClassFields = okWithFields+okAllHelpers; + +type TPasClassInterfaceType = ( citCom, // default @@ -1074,11 +1080,25 @@ type end; { TPasOperator } - TOperatorType = (otUnknown,otImplicit,otExplicit,otMul,otPlus, otMinus, otDivision,otLessThan, otEqual, - otGreaterThan, otAssign,otNotEqual,otLessEqualThan,otGreaterEqualThan,otPower, - otSymmetricalDifference, otInc, otDec, otMod, otNegative, otPositive, otBitWiseOr, otDiv, - otLeftShift, otLogicalOr, otBitwiseAnd, otbitwiseXor,otLogicalAnd,otLogicalNot,otLogicalXor, - otRightShift,otEnumerator, otIn); + TOperatorType = ( + otUnknown, + otImplicit, otExplicit, + otMul, otPlus, otMinus, otDivision, + otLessThan, otEqual, otGreaterThan, + otAssign, otNotEqual, otLessEqualThan, otGreaterEqualThan, + otPower, otSymmetricalDifference, + otInc, otDec, + otMod, + otNegative, otPositive, + otBitWiseOr, + otDiv, + otLeftShift, + otLogicalOr, + otBitwiseAnd, otbitwiseXor, + otLogicalAnd, otLogicalNot, otLogicalXor, + otRightShift, + otEnumerator, otIn + ); TOperatorTypes = set of TOperatorType; TPasOperator = class(TPasFunction) diff --git a/packages/fcl-passrc/src/pasuseanalyzer.pas b/packages/fcl-passrc/src/pasuseanalyzer.pas index 7cb066cb0d..404819fea3 100644 --- a/packages/fcl-passrc/src/pasuseanalyzer.pas +++ b/packages/fcl-passrc/src/pasuseanalyzer.pas @@ -1452,7 +1452,7 @@ begin begin if Ref.WithExprScope<>nil then begin - if Ref.WithExprScope.Scope is TPasRecordScope then + if Ref.WithExprScope.ClassRecScope is TPasRecordScope then begin // a record member was accessed -> access the record too UseExprRef(El,Ref.WithExprScope.Expr,Access,false); diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 69dfeff264..539f5f3271 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -135,7 +135,7 @@ resourcestring // free for 2029 SLogStartImplementation = 'Start parsing implementation section.'; SLogStartInterface = 'Start parsing interface section'; - SParserNoConstructorAllowed = 'Constructors or Destructors are not allowed in Interfaces or Record helpers'; + SParserNoConstructorAllowed = 'Constructors or Destructors are not allowed in Interfaces or Records'; 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.'; @@ -731,11 +731,7 @@ begin end; Parser := TPasParser.Create(Scanner, FileResolver, AEngine); if (poSkipDefaultDefs in Options) then - begin - Writeln('>>> Clearing <<<'); Parser.ImplicitUses.Clear; - end; - Writeln('Implicit >>>',Parser.ImplicitUses.Text,'<<<'); Filename := ''; Parser.LogEvents:=AEngine.ParserLogEvents; Parser.OnLog:=AEngine.Onlog; @@ -3353,13 +3349,27 @@ end; procedure TPasParser.ParseDeclarations(Declarations: TPasDeclarations); var + HadTypeSection: boolean; CurBlock: TDeclType; procedure SetBlock(NewBlock: TDeclType); begin if CurBlock=NewBlock then exit; if CurBlock=declType then - Engine.FinishScope(stTypeSection,Declarations); + begin + if msDelphi in CurrentModeswitches then + // Delphi allows forward types only inside a type section + Engine.FinishScope(stTypeSection,Declarations); + end; + if NewBlock=declType then + HadTypeSection:=true + else if (NewBlock=declNone) and HadTypeSection then + begin + HadTypeSection:=false; + if not (msDelphi in CurrentModeswitches) then + // ObjFPC allows forward types inside a whole section + Engine.FinishScope(stTypeSection,Declarations); + end; CurBlock:=NewBlock; Scanner.SetForceCaret(NewBlock=declType); end; @@ -3383,6 +3393,7 @@ var RecordEl: TPasRecordType; begin CurBlock := declNone; + HadTypeSection:=false; while True do begin if CurBlock in [DeclNone,declConst,declType] then @@ -3655,7 +3666,7 @@ begin break; end else if (Declarations is TInterfaceSection) - or (Declarations is TImplementationSection) then + or (Declarations is TImplementationSection) then begin SetBlock(declNone); ParseInitialization; @@ -4014,7 +4025,7 @@ begin end; if not (CurToken in [tkComma,tkSemicolon,tkGreaterThan]) then ParseExc(nParserExpectToken2Error,SParserExpectToken2Error, - [TokenInfos[tkComma], TokenInfos[tkColon], TokenInfos[tkGreaterThan]]); + [TokenInfos[tkComma], TokenInfos[tkGreaterThan]]); until CurToken = tkGreaterThan; end; @@ -6227,7 +6238,7 @@ begin ptOperator,ptClassOperator: begin NextToken; - IsTokenBased:=Curtoken<>tkIdentifier; + IsTokenBased:=CurToken<>tkIdentifier; if IsTokenBased then OT:=TPasOperator.TokenToOperatorType(CurTokenText) else @@ -6690,8 +6701,8 @@ Type Var CurVisibility : TPasMemberVisibility; CurSection : TSectionType; - haveClass , - IsMethodResolution: Boolean; // true means last token was class keyword + haveClass: boolean; // true means last token was class keyword + IsMethodResolution: Boolean; LastToken: TToken; PropEl: TPasProperty; MethodRes: TPasMethodResolution; @@ -6734,8 +6745,8 @@ begin tkVar: 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 + if (AType.ObjKind in okWithFields) + or (haveClass and (AType.ObjKind in okAllHelpers)) then // ok else ParseExc(nParserXNotAllowedInY,SParserXNotAllowedInY,['VAR',ObjKindNames[AType.ObjKind]]); @@ -6759,14 +6770,14 @@ begin stNone, stVar: begin - if not (AType.ObjKind in [okObject,okClass,okGeneric]) then + if not (AType.ObjKind in okWithFields) then ParseExc(nParserNoFieldsAllowed,SParserNoFieldsAllowedInX,[ObjKindNames[AType.ObjKind]]); ParseClassFields(AType,CurVisibility,CurSection=stClassVar); HaveClass:=False; end; stClassVar: begin - if not (AType.ObjKind in [okObject,okClass,okGeneric,okClassHelper,okRecordHelper,okTypeHelper]) then + if not (AType.ObjKind in okWithClassFields) then ParseExc(nParserNoFieldsAllowed,SParserNoFieldsAllowedInX,[ObjKindNames[AType.ObjKind]]); ParseClassFields(AType,CurVisibility,CurSection=stClassVar); HaveClass:=False; @@ -6780,12 +6791,19 @@ begin curSection:=stNone; if not haveClass then SaveComments; - if (AType.ObjKind in [okObject,okClass,okGeneric]) - or ((CurToken=tkconstructor) - and (AType.ObjKind in [okClassHelper,okTypeHelper,okRecordHelper])) then - // ok + case AType.ObjKind of + okObject,okClass,okGeneric: ; + okClassHelper,okTypeHelper,okRecordHelper: + begin + if (CurToken=tkdestructor) and not haveClass then + ParseExc(nParserXNotAllowedInY,SParserXNotAllowedInY,['destructor',ObjKindNames[AType.ObjKind]]); + end; else - ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed); + if CurToken=tkconstructor then + ParseExc(nParserXNotAllowedInY,SParserXNotAllowedInY,['constructor',ObjKindNames[AType.ObjKind]]) + else + ParseExc(nParserXNotAllowedInY,SParserXNotAllowedInY,['destructor',ObjKindNames[AType.ObjKind]]); + end; ProcessMethod(AType,HaveClass,CurVisibility); haveClass:=False; end; @@ -6891,7 +6909,7 @@ begin NextToken; AType.IsShortDefinition:=(CurToken=tkSemicolon); end; - if (AType.ObjKind in [okClassHelper,okRecordHelper,okTypeHelper]) then + if (AType.ObjKind in okAllHelpers) then begin CheckToken(tkfor); NextToken; @@ -6963,7 +6981,7 @@ begin AExternalNameSpace:=''; AExternalName:=''; end; - if AObjKind in [okClassHelper,okRecordHelper,okTypeHelper] then + if AObjKind in okAllHelpers then begin if not CurTokenIsIdentifier('Helper') then ParseExcSyntaxError; diff --git a/packages/fcl-passrc/src/pscanner.pp b/packages/fcl-passrc/src/pscanner.pp index b06a8b5160..dde54fe003 100644 --- a/packages/fcl-passrc/src/pscanner.pp +++ b/packages/fcl-passrc/src/pscanner.pp @@ -294,8 +294,9 @@ type msExternalClass, { Allow external class definitions } msPrefixedAttributes, { Allow attributes, disable proc modifier [] } msIgnoreAttributes, { workaround til resolver/converter supports attributes } - msOmitRTTI { treat class section 'published' as 'public' and typeinfo does not work on symbols declared with this switch } - ); + msOmitRTTI, { treat class section 'published' as 'public' and typeinfo does not work on symbols declared with this switch } + msMultipleScopeHelpers { off=only one helper per type, on=all } + ); TModeSwitches = Set of TModeSwitch; // switches, that can be 'on' or 'off' @@ -987,7 +988,7 @@ const 'Tab' ); - SModeSwitchNames : array[TModeSwitch] of string{$ifdef fpc}[18]{$endif} = + SModeSwitchNames : array[TModeSwitch] of string{$ifdef fpc}[20]{$endif} = ( '', // msNone '', // Fpc, '', // Objfpc, @@ -1037,7 +1038,8 @@ const 'EXTERNALCLASS', 'PREFIXEDATTRIBUTES', 'IGNOREATTRIBUTES', - 'OMITRTTI' + 'OMITRTTI', + 'MULTIPLESCOPEHELPERS' ); LetterSwitchNames: array['A'..'Z'] of string=( diff --git a/packages/fcl-passrc/tests/tcgenerics.pp b/packages/fcl-passrc/tests/tcgenerics.pp index 982bcff6d0..dd60a1067b 100644 --- a/packages/fcl-passrc/tests/tcgenerics.pp +++ b/packages/fcl-passrc/tests/tcgenerics.pp @@ -12,20 +12,21 @@ Type { TTestGenerics } TTestGenerics = Class(TBaseTestTypeParser) - private Published Procedure TestObjectGenerics; Procedure TestRecordGenerics; Procedure TestArrayGenerics; + Procedure TestGenericConstraint; + Procedure TestDeclarationConstraint; Procedure TestSpecializationDelphi; - procedure TestDeclarationConstraint; Procedure TestDeclarationDelphi; Procedure TestDeclarationDelphiSpecialize; - procedure TestDeclarationFPC; + Procedure TestDeclarationFPC; Procedure TestMethodImplementation; Procedure TestInlineSpecializationInArgument; Procedure TestSpecializeNested; Procedure TestInlineSpecializeInStatement; + Procedure TestGenericFunction; // ToDo end; implementation @@ -61,6 +62,37 @@ begin ParseDeclarations; end; +procedure TTestGenerics.TestGenericConstraint; +begin + Add([ + 'Type', + 'Generic TSomeClass = class', + ' b : T;', + 'end;', + '']); + ParseDeclarations; +end; + +procedure TTestGenerics.TestDeclarationConstraint; +Var + T : TPasClassType; +begin + Scanner.CurrentModeSwitches:=[msDelphi]+Scanner.CurrentModeSwitches ; + Source.Add('Type'); + Source.Add(' TSomeClass = Class(TObject)'); + Source.Add(' b : T;'); + Source.Add('end;'); + ParseDeclarations; + AssertNotNull('have generic definition',Declarations.Classes); + AssertEquals('have generic definition',1,Declarations.Classes.Count); + AssertEquals('Pascal class',TPasClassType,TObject(Declarations.Classes[0]).ClassType); + T:=TPasClassType(Declarations.Classes[0]); + AssertNotNull('have generic templates',T.GenericTemplateTypes); + AssertEquals('1 template types',1,T.GenericTemplateTypes.Count); + AssertSame('Parent 0 is class',T,TPasElement(T.GenericTemplateTypes[0]).Parent); + AssertEquals('Type constraint is recorded','T2',TPasGenericTemplateType(T.GenericTemplateTypes[0]).TypeConstraint); +end; + procedure TTestGenerics.TestSpecializationDelphi; begin ParseType('TFPGList',TPasSpecializeType,''); @@ -87,48 +119,6 @@ begin AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent); end; -procedure TTestGenerics.TestDeclarationFPC; -Var - T : TPasClassType; -begin - Scanner.CurrentModeSwitches:=[msDelphi]+Scanner.CurrentModeSwitches ; - Source.Add('Type'); - Source.Add(' TSomeClass = Class(TObject)'); - Source.Add(' b : T;'); - Source.Add(' b2 : T2;'); - Source.Add('end;'); - ParseDeclarations; - AssertNotNull('have generic definition',Declarations.Classes); - AssertEquals('have generic definition',1,Declarations.Classes.Count); - AssertEquals('Pascal class',TPasClassType,TObject(Declarations.Classes[0]).ClassType); - T:=TPasClassType(Declarations.Classes[0]); - AssertNotNull('have generic templates',T.GenericTemplateTypes); - AssertEquals('2 template types',2,T.GenericTemplateTypes.Count); - AssertSame('Parent 0 is class',T,TPasElement(T.GenericTemplateTypes[0]).Parent); - AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent); -end; - - -procedure TTestGenerics.TestDeclarationConstraint; -Var - T : TPasClassType; -begin - Scanner.CurrentModeSwitches:=[msDelphi]+Scanner.CurrentModeSwitches ; - Source.Add('Type'); - Source.Add(' TSomeClass = Class(TObject)'); - Source.Add(' b : T;'); - Source.Add('end;'); - ParseDeclarations; - AssertNotNull('have generic definition',Declarations.Classes); - AssertEquals('have generic definition',1,Declarations.Classes.Count); - AssertEquals('Pascal class',TPasClassType,TObject(Declarations.Classes[0]).ClassType); - T:=TPasClassType(Declarations.Classes[0]); - AssertNotNull('have generic templates',T.GenericTemplateTypes); - AssertEquals('1 template types',1,T.GenericTemplateTypes.Count); - AssertSame('Parent 0 is class',T,TPasElement(T.GenericTemplateTypes[0]).Parent); - AssertEquals('Type constraint is recorded','T2',TPasGenericTemplateType(T.GenericTemplateTypes[0]).TypeConstraint); -end; - procedure TTestGenerics.TestDeclarationDelphiSpecialize; Var T : TPasClassType; @@ -151,6 +141,27 @@ begin AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent); end; +procedure TTestGenerics.TestDeclarationFPC; +Var + T : TPasClassType; +begin + Scanner.CurrentModeSwitches:=[msDelphi]+Scanner.CurrentModeSwitches; + Source.Add('Type'); + Source.Add(' TSomeClass = Class(TObject)'); + Source.Add(' b : T;'); + Source.Add(' b2 : T2;'); + Source.Add('end;'); + ParseDeclarations; + AssertNotNull('have generic definition',Declarations.Classes); + AssertEquals('have generic definition',1,Declarations.Classes.Count); + AssertEquals('Pascal class',TPasClassType,TObject(Declarations.Classes[0]).ClassType); + T:=TPasClassType(Declarations.Classes[0]); + AssertNotNull('have generic templates',T.GenericTemplateTypes); + AssertEquals('2 template types',2,T.GenericTemplateTypes.Count); + AssertSame('Parent 0 is class',T,TPasElement(T.GenericTemplateTypes[0]).Parent); + AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent); +end; + procedure TTestGenerics.TestMethodImplementation; begin With source do @@ -206,6 +217,19 @@ begin ParseModule; end; +procedure TTestGenerics.TestGenericFunction; +begin + exit; // ToDo + Add([ + 'generic function IfThen(val:boolean;const iftrue:T; const iffalse:T) :T; inline; overload;', + 'begin', + 'end;', + 'begin', + ' IfThen(true,2,3);', + '']); + ParseModule; +end; + initialization RegisterTest(TTestGenerics); end. diff --git a/packages/fcl-passrc/tests/tcprocfunc.pas b/packages/fcl-passrc/tests/tcprocfunc.pas index d90c274e25..ff695b020d 100644 --- a/packages/fcl-passrc/tests/tcprocfunc.pas +++ b/packages/fcl-passrc/tests/tcprocfunc.pas @@ -1273,18 +1273,20 @@ procedure TTestProcedureFunction.TestOperatorNames; Var t : TOperatorType; + S: String; begin For t:=Succ(otUnknown) to High(TOperatorType) do begin + S:=GetEnumName(TypeInfo(TOperatorType),Ord(T)); ResetParser; if t in UnaryOperators then AddDeclaration(Format('operator %s (a: Integer) : te',[OperatorNames[t]])) else AddDeclaration(Format('operator %s (a: Integer; b: integer) : te',[OperatorNames[t]])); ParseOperator; - AssertEquals('Token based',False,FOperator.TokenBased); - AssertEquals('Correct operator type',T,FOperator.OperatorType); + AssertEquals(S+': Token based',t in [otIn],FOperator.TokenBased); + AssertEquals(S+': Correct operator type',T,FOperator.OperatorType); if t in UnaryOperators then AssertEquals('Correct operator name',format('%s(Integer):te',[OperatorNames[t]]),FOperator.Name) else diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 3b6c9b6245..0f9e7f13d0 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -490,6 +490,7 @@ type Procedure TestAdvRecord; Procedure TestAdvRecord_Private; Procedure TestAdvRecord_StrictPrivate; + Procedure TestAdvRecord_StrictPrivateFail; Procedure TestAdvRecord_MethodImplMissingFail; Procedure TestAdvRecord_VarConst; Procedure TestAdvRecord_RecVal_ConstFail; @@ -520,6 +521,9 @@ type Procedure TestClassForwardAsAncestorFail; Procedure TestClassForwardNotResolved; Procedure TestClassForwardDuplicateFail; + Procedure TestClassForwardDelphiFail; + Procedure TestClassForwardObjFPCProgram; + Procedure TestClassForwardObjFPCUnit; Procedure TestClass_Method; Procedure TestClass_ConstructorMissingDotFail; Procedure TestClass_MethodImplDuplicateFail; @@ -658,6 +662,8 @@ type Procedure TestPropertyReadAccessorFuncWrongResult; Procedure TestPropertyReadAccessorFuncWrongArgCount; Procedure TestPropertyReadAccessorFunc; + Procedure TestPropertyReadAccessorStrictPrivate; + Procedure TestPropertyReadAccessorNonClassFail; Procedure TestPropertyWriteAccessorVarWrongType; Procedure TestPropertyWriteAccessorFuncNotProc; Procedure TestPropertyWriteAccessorProcWrongArgCount; @@ -863,12 +869,35 @@ type // helpers Procedure ClassHelper; Procedure ClassHelper_AncestorIsNotHelperForDescendantFail; + Procedure ClassHelper_HelperForParentFail; Procedure ClassHelper_ForInterfaceFail; Procedure ClassHelper_FieldFail; Procedure ClassHelper_AbstractFail; Procedure ClassHelper_VirtualObjFPCFail; + Procedure ClassHelper_VirtualDelphiFail; + Procedure ClassHelper_DestructorFail; + Procedure ClassHelper_ClassRefersToTypeHelperOfAncestor; + Procedure ClassHelper_InheritedObjFPC; + Procedure ClassHelper_InheritedObjFPC2; + Procedure ClassHelper_InheritedObjFPCStrictPrivateFail; + Procedure ClassHelper_InheritedDelphi; + Procedure ClassHelper_NestedInheritedParentFail; + Procedure ClassHelper_AccessFields; + Procedure ClassHelper_CallClassMethodFail; + Procedure ClassHelper_AsTypeFail; + Procedure ClassHelper_Enumerator; + Procedure ClassHelper_FromUnitInterface; + // ToDo ClassHelper_Constructor + // ToDo ClassHelper_DefaultProperty + // ToDo ClassHelper_MultiScopeHelpers Procedure RecordHelper; + // RecordHelper_Constructor Procedure TypeHelper; + Procedure TypeHelper_HelperForProcTypeFail; + Procedure TypeHelper_DefaultPropertyFail; + Procedure TypeHelper_Enum; + Procedure TypeHelper_Enumerator; + // TypeHelper_Constructor // attributes Procedure TestAttributes_Ignore; @@ -7872,6 +7901,30 @@ begin end; procedure TTestResolver.TestAdvRecord_StrictPrivate; +begin + StartProgram(false); + Add([ + '{$modeswitch advancedrecords}', + 'type', + ' TRec = record', + ' strict private', + ' FSize: longword;', + ' function GetSize: longword;', + ' public', + ' property Size: longword read GetSize write FSize;', + ' end;', + 'function TRec.GetSize: longword;', + 'begin', + ' FSize:=GetSize;', + 'end;', + 'var', + ' r: TRec;', + 'begin', + ' r.Size:=r.Size;']); + ParseProgram; +end; + +procedure TTestResolver.TestAdvRecord_StrictPrivateFail; begin StartProgram(false); Add([ @@ -7885,7 +7938,7 @@ begin ' r: TRec;', 'begin', ' r.a:=r.a;']); - CheckResolverException('Can''t access strict private member A',nCantAccessPrivateMember); + CheckResolverException('Can''t access strict private member A',nCantAccessXMember); end; procedure TTestResolver.TestAdvRecord_MethodImplMissingFail; @@ -8616,6 +8669,62 @@ begin CheckResolverException('Duplicate identifier "TObject" at afile.pp(3,10)',nDuplicateIdentifier); end; +procedure TTestResolver.TestClassForwardDelphiFail; +begin + StartProgram(false); + Add([ + '{$mode delphi}', + 'type', + ' TObject = class end;', + ' TBird = class;', + 'const k = 1;', + 'type', + ' TBird = class', + ' end;', + 'begin']); + CheckResolverException('Forward type not resolved "TBird"',nForwardTypeNotResolved); +end; + +procedure TTestResolver.TestClassForwardObjFPCProgram; +begin + StartProgram(false); + Add([ + '{$mode objfpc}', + 'type', + ' TObject = class end;', + ' TBird = class;', + 'const k = 1;', + 'type', + ' TBird = class', + ' end;', + 'begin']); + ParseProgram; +end; + +procedure TTestResolver.TestClassForwardObjFPCUnit; +begin + StartUnit(false); + Add([ + '{$mode objfpc}', + 'interface', + 'type', + ' TObject = class end;', + ' TBird = class;', + 'const k = 1;', + 'type', + ' TBird = class', + ' end;', + 'implementation', + 'type', + ' TEagle = class;', + 'const c = 1;', + 'type', + ' TEagle = class', + ' end;', + '']); + ParseUnit; +end; + procedure TTestResolver.TestClass_Method; begin StartProgram(false); @@ -9912,7 +10021,7 @@ begin Add('begin'); Add(' if o.v=3 then ;'); CheckResolverException('Can''t access private member v', - nCantAccessPrivateMember); + nCantAccessXMember); end; procedure TTestResolver.TestClass_PrivateInDescendantFail; @@ -9940,7 +10049,7 @@ begin Add('end;'); Add('begin'); CheckResolverException('Can''t access private member v', - nCantAccessPrivateMember); + nCantAccessXMember); end; procedure TTestResolver.TestClass_ProtectedInDescendant; @@ -10002,7 +10111,7 @@ begin Add('begin'); Add(' if o.v=3 then ;'); CheckResolverException('Can''t access strict private member v', - nCantAccessPrivateMember); + nCantAccessXMember); end; procedure TTestResolver.TestClass_StrictProtectedInMainBeginFail; @@ -10017,7 +10126,7 @@ begin Add('begin'); Add(' if o.v=3 then ;'); CheckResolverException('Can''t access strict protected member v', - nCantAccessPrivateMember); + nCantAccessXMember); end; procedure TTestResolver.TestClass_Constructor_NewInstance; @@ -10809,7 +10918,7 @@ begin ' Arm: TObject.TArm;', 'begin', '']); - CheckResolverException('Can''t access strict private member TArm',nCantAccessPrivateMember); + CheckResolverException('Can''t access strict private member TArm',nCantAccessXMember); end; procedure TTestResolver.TestNestedClass_AccessStrictPrivate; @@ -11580,6 +11689,42 @@ begin ParseProgram; end; +procedure TTestResolver.TestPropertyReadAccessorStrictPrivate; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class', + ' strict private', + ' FSize: word;', + ' property Size: word read FSize;', + ' strict protected', + ' FName: string;', + ' property Name: string read FName;', + ' end;', + ' TBird = class', + ' strict protected', + ' property Caption: string read FName;', + ' end;', + 'begin', + '']); + ParseProgram; +end; + +procedure TTestResolver.TestPropertyReadAccessorNonClassFail; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class', + ' FSize: word;', + ' class property Size: word read FSize;', + ' end;', + 'begin', + '']); + CheckResolverException('class var expected, but var found',nXExpectedButYFound); +end; + procedure TTestResolver.TestPropertyWriteAccessorVarWrongType; begin StartProgram(false); @@ -12219,7 +12364,7 @@ begin ' constructor Create;', ' end;', 'begin']); - CheckParserException(SParserNoConstructorAllowed,nParserNoConstructorAllowed); + CheckParserException('constructor is not allowed in interface',nParserXNotAllowedInY); end; procedure TTestResolver.TestClassInterface_DelphiClassAncestorIntfFail; @@ -15203,7 +15348,6 @@ begin ' PInteger = ^integer;', 'var', ' i: integer;', - ' p1: PInteger;', 'begin', '']); CheckResolverException('identifier not found "integer"',nIdentifierNotFound); @@ -15544,6 +15688,24 @@ begin nDerivedXMustExtendASubClassY); end; +procedure TTestResolver.ClassHelper_HelperForParentFail; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class', + ' end;', + ' TBird = class(TObject)', + ' type', + ' TBirdHelper = class helper for TBird', + ' end;', + ' end;', + 'begin', + '']); + CheckResolverException(sTypeXIsNotYetCompletelyDefined, + nTypeXIsNotYetCompletelyDefined); +end; + procedure TTestResolver.ClassHelper_ForInterfaceFail; begin StartProgram(false); @@ -15611,6 +15773,405 @@ begin nInvalidXModifierY); end; +procedure TTestResolver.ClassHelper_VirtualDelphiFail; +begin + StartProgram(false); + Add([ + '{$mode delphi}', + '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.ClassHelper_DestructorFail; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class', + ' end;', + ' TObjHelper = class helper for TObject', + ' destructor Destroyer;', + ' end;', + 'destructor TObjHelper.Destroyer;', + 'begin end;', + 'begin', + '']); + CheckParserException('destructor is not allowed in class helper', + nParserXNotAllowedInY); +end; + +procedure TTestResolver.ClassHelper_ClassRefersToTypeHelperOfAncestor; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class', + ' end;', + ' TObjHelper = class helper for TObject', + ' type', + ' TInt = word;', + ' function GetSize: TInt;', + ' end;', + ' TAnt = class', + ' procedure SetSize(Value: TInt);', + ' property Size: TInt read GetSize write SetSize;', + ' end;', + 'function Tobjhelper.getSize: TInt;', + 'begin', + 'end;', + 'procedure TAnt.SetSize(Value: TInt);', + 'begin', + 'end;', + 'begin', + '']); + ParseProgram; +end; + +procedure TTestResolver.ClassHelper_InheritedObjFPC; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class', + ' procedure {#TObject_Fly}Fly;', + ' end;', + ' TObjHelper = class helper for TObject', + ' procedure {#TObjHelper_Fly}Fly;', + ' end;', + ' TBird = class', + ' procedure {#TBird_Fly}Fly;', + ' end;', + ' TBirdHelper = class helper for TBird', + ' procedure {#TBirdHelper_Fly}Fly;', + ' procedure {#TBirdHelper_Walk}Walk;', + ' end;', + ' TEagleHelper = class helper(TBirdHelper) for TBird', + ' procedure {#TEagleHelper_Fly}Fly;', + ' procedure {#TEagleHelper_Walk}Walk;', + ' end;', + 'procedure Tobject.fly;', + 'begin', + ' inherited;', // ignore + 'end;', + 'procedure Tobjhelper.fly;', + 'begin', + ' {@TObject_Fly}inherited;', + ' inherited {@TObject_Fly}Fly;', + 'end;', + 'procedure Tbird.fly;', + 'begin', + ' {@TObjHelper_Fly}inherited;', + ' inherited {@TObjHelper_Fly}Fly;', + 'end;', + 'procedure Tbirdhelper.fly;', + 'begin', + ' {@TBird_Fly}inherited;', + ' inherited {@TBird_Fly}Fly;', + 'end;', + 'procedure Tbirdhelper.walk;', + 'begin', + 'end;', + 'procedure teagleHelper.fly;', + 'begin', + ' {@TBird_Fly}inherited;', + ' inherited {@TBird_Fly}Fly;', + 'end;', + 'procedure teagleHelper.walk;', + 'begin', + ' {@TBirdHelper_Walk}inherited;', + ' inherited {@TBirdHelper_Walk}Walk;', + 'end;', + 'begin', + '']); + ParseProgram; +end; + +procedure TTestResolver.ClassHelper_InheritedObjFPC2; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class', + ' procedure {#TObject_Fly}Fly;', + ' end;', + ' TObjHelper = class helper for TObject', + ' procedure {#TObjHelper_Walk}Walk;', + ' end;', + ' TBird = class', + ' procedure {#TBird_Fly}Fly;', + ' end;', + ' TBirdHelper = class helper for TBird', + ' procedure {#TBirdHelper_Walk}Walk;', + ' end;', + ' TEagleHelper = class helper(TBirdHelper) for TBird', + ' procedure {#TEagleHelper_Walk}Walk;', + ' end;', + 'procedure Tobject.fly;', + 'begin', + ' inherited;', // ignore + 'end;', + 'procedure Tobjhelper.walk;', + 'begin', + ' inherited;', // ignore + 'end;', + 'procedure Tbird.fly;', + 'begin', + ' {@TObject_Fly}inherited;', // no helper, search further in ancestor + ' inherited {@TObject_Fly}Fly;', // no helper, search further in ancestor + 'end;', + 'procedure Tbirdhelper.walk;', + 'begin', + ' {@TObjHelper_Walk}inherited;', + ' inherited {@TObjHelper_Walk}Walk;', + 'end;', + 'procedure teagleHelper.walk;', + 'begin', + ' {@TObjHelper_Walk}inherited;', + ' inherited {@TObjHelper_Walk}Walk;', + 'end;', + 'begin', + '']); + ParseProgram; +end; + +procedure TTestResolver.ClassHelper_InheritedObjFPCStrictPrivateFail; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class', + ' strict private i: word;', + ' end;', + ' THelper = class helper for TObject', + ' property a: word read i;', + ' end;', + 'begin', + '']); + CheckResolverException('Can''t access strict private member i',nCantAccessXMember); +end; + +procedure TTestResolver.ClassHelper_InheritedDelphi; +begin + StartProgram(false); + Add([ + '{$mode delphi}', + 'type', + ' TObject = class', + ' procedure {#TObject_Fly}Fly;', + ' end;', + ' TObjHelper = class helper for TObject', + ' procedure {#TObjHelper_Fly}Fly;', + ' end;', + ' TBird = class', + ' procedure {#TBird_Fly}Fly;', + ' end;', + ' TBirdHelper = class helper for TBird', + ' procedure {#TBirdHelper_Fly}Fly;', + ' procedure {#TBirdHelper_Walk}Walk;', + ' end;', + ' TEagleHelper = class helper(TBirdHelper) for TBird', + ' procedure {#TEagleHelper_Fly}Fly;', + ' procedure {#TEagleHelper_Walk}Walk;', + ' end;', + 'procedure Tobject.fly;', + 'begin', + ' inherited;', // ignore + 'end;', + 'procedure Tobjhelper.fly;', + 'begin', + ' inherited;', // ignore + ' inherited {@TObject_Fly}Fly;', + 'end;', + 'procedure Tbird.fly;', + 'begin', + ' {@TObjHelper_Fly}inherited;', + ' inherited {@TObjHelper_Fly}Fly;', + 'end;', + 'procedure Tbirdhelper.fly;', + 'begin', + ' {@TObjHelper_Fly}inherited;',// skip helperfortype too + ' inherited {@TBird_Fly}Fly;', + 'end;', + 'procedure Tbirdhelper.walk;', + 'begin', + 'end;', + 'procedure teagleHelper.fly;', + 'begin', + ' {@TObjHelper_Fly}inherited;',// skip helperfortype too + ' inherited {@TBird_Fly}Fly;', + 'end;', + 'procedure teagleHelper.walk;', + 'begin', + ' inherited;', // ignore + ' inherited {@TBirdHelper_Walk}Walk;', + 'end;', + 'begin', + '']); + ParseProgram; +end; + +procedure TTestResolver.ClassHelper_NestedInheritedParentFail; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class', + ' end;', + ' TBird = class', + ' procedure Fly;', + ' type', + ' TBirdHelper = class helper for TObject', + ' procedure Fly;', + ' end;', + ' end;', + 'procedure TBird.fly;', + 'begin', + 'end;', + 'procedure TBird.Tbirdhelper.fly;', + 'begin', + ' inherited Fly;', + 'end;', + 'begin', + '']); + CheckResolverException('identifier not found "Fly"',nIdentifierNotFound); +end; + +procedure TTestResolver.ClassHelper_AccessFields; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class end;', + ' TBird = class', + ' Size: word;', + ' FItems: array of word;', + ' end;', + ' TBirdHelper = class helper for TBird', + ' procedure Fly;', + ' end;', + 'procedure TBirdHelper.Fly;', + 'begin', + ' Size:=FItems[0];', + ' Self.Size:=Self.FItems[0];', + 'end;', + 'var', + ' b: TBird;', + 'begin', + ' b.Fly;', + ' b.Fly()', + '']); + ParseProgram; +end; + +procedure TTestResolver.ClassHelper_CallClassMethodFail; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class end;', + ' THelper = class helper for TObject', + ' class procedure Fly;', + ' end;', + 'class procedure THelper.Fly;', + 'begin', + 'end;', + 'begin', + ' THelper.Fly;', + '']); + CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes); +end; + +procedure TTestResolver.ClassHelper_AsTypeFail; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class end;', + ' THelper = class helper for TObject', + ' end;', + 'var h: THelper;', + 'begin', + '']); + CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes); +end; + +procedure TTestResolver.ClassHelper_Enumerator; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class end;', + ' TItem = TObject;', + ' TEnumerator = class', + ' FCurrent: TItem;', + ' property Current: TItem read FCurrent;', + ' function MoveNext: boolean;', + ' end;', + ' TBird = class', + ' FItems: array of TItem;', + ' end;', + ' TBirdHelper = class helper for TBird', + ' function GetEnumerator: TEnumerator;', + ' end;', + 'function TEnumerator.MoveNext: boolean;', + 'begin', + 'end;', + 'function TBirdHelper.GetEnumerator: TEnumerator;', + 'begin', + ' Result.FCurrent:=FItems[0];', + ' Result.FCurrent:=Self.FItems[0];', + 'end;', + 'var', + ' b: TBird;', + ' i: TItem;', + ' {#i2}i2: TItem;', + 'begin', + ' for i in b do {@i2}i2:=i;']); + ParseProgram; +end; + +procedure TTestResolver.ClassHelper_FromUnitInterface; +begin + AddModuleWithIntfImplSrc('unit2.pas', + LinesToStr([ + 'type', + ' TObject = class', + ' public', + ' Id: word;', + ' end;', + ' TObjHelper = class helper for TObject', + ' property Size: word read ID write ID;', + ' end;', + '']), + ''); + AddModuleWithIntfImplSrc('unit3.pas', + LinesToStr([ + 'uses unit2;', + 'type', + ' TObjHelper = class helper for TObject', + ' property Size: word read ID write ID;', + ' end;', + '']), + ''); + StartProgram(true); + Add([ + 'uses unit2, unit3;', + 'var o: TObject;', + 'begin', + ' o.Size:=o.Size;']); + ParseProgram; +end; + procedure TTestResolver.RecordHelper; begin StartProgram(false); @@ -15618,6 +16179,7 @@ begin '{$mode delphi}', 'type', ' TRec = record', + ' x: word;', ' end;', ' TRecHelper = record helper for TRec', ' type T = word;', @@ -15627,10 +16189,19 @@ begin ' class var', ' v: T;', ' w: T;', + ' procedure Fly;', ' end;', ' TAnt = word;', ' TAntHelper = record helper for TAnt', ' end;', + 'procedure TRecHelper.Fly;', + 'var r: TRec;', + 'begin', + ' Self:=r;', + ' r:=Self;', + ' c:=v+x;', + ' x:=k+w;', + 'end;', 'begin', '']); ParseProgram; @@ -15652,6 +16223,99 @@ begin ParseProgram; end; +procedure TTestResolver.TypeHelper_HelperForProcTypeFail; +begin + StartProgram(false); + Add([ + '{$modeswitch typehelpers}', + 'type', + ' TProc = procedure;', + ' THelper = type helper for TProc', + ' end;', + 'begin', + '']); + CheckResolverException('Type "TProc" cannot be extended by a type helper', + nTypeXCannotBeExtendedByATypeHelper); +end; + +procedure TTestResolver.TypeHelper_DefaultPropertyFail; +begin + StartProgram(false); + Add([ + '{$modeswitch typehelpers}', + 'type', + ' TStringHelper = type helper for string', + ' end;', + ' TCaption = string;', + ' TCapHelper = type helper(TStringHelper) for TCaption', + ' function GetItems(Index: boolean): boolean;', + ' property Items[Index: boolean]: boolean read GetItems; default;', + ' end;', + 'function TCapHelper.GetItems(Index: boolean): boolean; begin end;', + 'begin', + '']); + CheckResolverException('Default property not allowed in helper for TCaption', + nDefaultPropertyNotAllowedInHelperForX); +end; + +procedure TTestResolver.TypeHelper_Enum; +begin + StartProgram(false); + Add([ + '{$modeswitch typehelpers}', + 'type', + ' TFlag = (Red, Green, Blue);', + ' THelper = type helper for TFlag', + ' function toString: string;', + ' end;', + 'function THelper.toString: string;', + 'begin', + ' Self:=Red;', + ' if Self=TFlag.Blue then ;', + ' Result:=str(Self);', + 'end;', + 'var', + ' f: TFlag;', + 'begin', + ' f.toString;', + '']); + ParseProgram; +end; + +procedure TTestResolver.TypeHelper_Enumerator; +begin + StartProgram(false); + Add([ + '{$modeswitch typehelpers}', + 'type', + ' TObject = class end;', + ' TItem = byte;', + ' TEnumerator = class', + ' FCurrent: TItem;', + ' property Current: TItem read FCurrent;', + ' function MoveNext: boolean;', + ' end;', + ' TWordHelper = type helper for Word', + ' function GetEnumerator: TEnumerator;', + ' end;', + 'function TEnumerator.MoveNext: boolean;', + 'begin', + 'end;', + 'function TWordHelper.GetEnumerator: TEnumerator;', + 'begin', + ' if Self=2 then ;', + ' Self:=Self+3;', + 'end;', + 'var', + ' w: word;', + ' i: TItem;', + ' {#i2}i2: TItem;', + 'begin', + ' w.GetEnumerator;', + ' for i in w do {@i2}i2:=i;']); + ParseProgram; +end; + procedure TTestResolver.TestAttributes_Ignore; begin StartProgram(false);