From c7523c623651ba98c9bb6fde3336490122cacac1 Mon Sep 17 00:00:00 2001 From: michael Date: Thu, 22 Sep 2016 11:41:09 +0000 Subject: [PATCH] * Patch from Mattias Gaertner with support for - class forward declaration - alias class, type alias class - ancestor, TObject as default - virtual, override, abstract - property read, write, stored - methods - self - overloaded procs with class as argument git-svn-id: trunk@34555 - --- packages/fcl-passrc/src/pasresolver.pp | 1704 ++++++++++++++++++-- packages/fcl-passrc/src/pastree.pp | 29 +- packages/fcl-passrc/src/pparser.pp | 245 ++- packages/fcl-passrc/src/pscanner.pp | 3 +- packages/fcl-passrc/tests/tcexprparser.pas | 13 +- packages/fcl-passrc/tests/tcresolver.pas | 1445 ++++++++++++++++- packages/fcl-passrc/tests/tctypeparser.pas | 14 + packages/pastojs/tests/tcconverter.pp | 5 - 8 files changed, 3159 insertions(+), 299 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index dd2646aa94..4f9d7c63c1 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -26,6 +26,8 @@ - interface and implementation types, vars, const - params, local types, vars, const - nested procedures + - nested forward procs, nested must be resolved before proc body + - program/library/implementation forward procs - search in used units - unitname.identifier - alias types, 'type a=b' @@ -39,18 +41,41 @@ - try..finally..except, on, else, raise - for loop - spot duplicates + - class: + - forward declaration + - instance.a + - find ancestor, search in ancestors + - virtual, abstract, override + - method body + - Self + - inherited + - property + - read var, read function + - write var, write function + - stored function ToDo: - - records - TPasRecordType, + - add global error ids + - classes - TPasClassType + - tests for ancestor TPasAliasType + - class methods + - property indexed + - class of + - visibility + - nested var, const + - nested types + - with - TPasImplWithDo + - procedure type + - method type + - records - TPasRecordType, - variant - TPasVariant - const TRecordValues - - check if types only refer types - - nested forward procs, nested must be resolved before proc body - - program/library/implementation forward procs - - check if constant is longint or int64 - - built-in functions - enums - TPasEnumType, TPasEnumValue - - propagate to parent scopes + - propagate to parent scopes + - check if types only refer types + - check if constant is longint or int64 + - check property default type + - built-in functions - ranges TPasRangeType - arrays TPasArrayType - const TArrayValues @@ -58,8 +83,6 @@ - untyped parameters - sets - TPasSetType - forwards of ^pointer and class of - must be queued and resolved at end of type section - - with - TPasImplWithDo - - classes - TPasClassType - interfaces - properties - TPasProperty - read, write, index properties, implements, stored @@ -67,12 +90,12 @@ - TPasResString - TPasFileType - generics, nested param lists - - visibility (private, protected, strict private, strict protected) - check const expression types, e.g. bark on "const c:string=3;" - dotted unitnames - labels - helpers - generics + - operator overload - many more: search for "ToDo:" Debug flags: -d @@ -103,6 +126,22 @@ const nIncompatibleTypeArgNoVarParamMustMatchExactly = 3007; nVariableIdentifierExpected = 3008; nDuplicateIdentifier = 3009; + nXExpectedButYFound = 3010; + nAncestorCycleDetected = 3011; + nCantUseForwardDeclarationAsAncestor = 3012; + nCantDetermineWhichOverloadedFunctionToCall = 3013; + nForwardTypeNotResolved = 3014; + nForwardProcNotResolved = 3015; + nInvalidProcModifiers = 3016; + nAbstractMethodsMustNotHaveImplementation = 3017; + nCallingConventionMismatch = 3018; + nResultTypeMismatchExpectedButFound = 3019; + nFunctionHeaderMismatchForwardVarName = 3020; + nFunctionHidesIdentifier = 3021; + nNoMethodInAncestorToOverride = 3022; + nInheritedOnlyWorksInMethods = 3023; + nInheritedNeedsAncestor = 3024; + nNoPropertyFoundToOverride = 3025; // resourcestring patterns of messages resourcestring @@ -115,6 +154,22 @@ resourcestring sIncompatibleTypeArgNoVarParamMustMatchExactly = 'Incompatible type arg no. %s: Got "%s", expected "%s". Var param must match exactly.'; sVariableIdentifierExpected = 'Variable identifier expected'; sDuplicateIdentifier = 'Duplicate identifier "%s" at %s'; + sXExpectedButYFound = '%s expected, but %s found'; + sAncestorCycleDetected = 'Ancestor cycle detected'; + sCantUseForwardDeclarationAsAncestor = 'Can''t use forward declaration "%s" as ancestor'; + sCantDetermineWhichOverloadedFunctionToCall = 'Can''t determine which overloaded function to call'; + sForwardTypeNotResolved = 'Forward type not resolved "%s"'; + sForwardProcNotResolved = 'Forward %s not resolved "%s"'; + sInvalidProcModifiers = 'Invalid %s modifiers %s'; + sAbstractMethodsMustNotHaveImplementation = 'Abstract method must not have an implementation.'; + sCallingConventionMismatch = 'Calling convention mismatch'; + sResultTypeMismatchExpectedButFound = 'Result type mismatch, expected %s, but found %s'; + sFunctionHeaderMismatchForwardVarName = 'function header "%s" doesn''t match forward : var name changes %s => %s'; + sFunctionHidesIdentifier = 'function hides identifier "%s" at "%s"'; + sNoMethodInAncestorToOverride = 'There is no method in an ancestor class to be overridden "%s"'; + sInheritedOnlyWorksInMethods = 'Inherited works only in methods'; + sInheritedNeedsAncestor = 'inherited needs an ancestor'; + sNoPropertyFoundToOverride = 'No property found to override'; type TResolveBaseType = ( @@ -355,6 +410,7 @@ type constructor Create; override; destructor Destroy; override; function FindIdentifier(const Identifier: String): TPasIdentifier; virtual; + function RemoveIdentifier(El: TPasElement): boolean; virtual; function AddIdentifier(const Identifier: String; El: TPasElement; const Kind: TPasIdentifierKind): TPasIdentifier; function FindElement(const aName: string): TPasElement; @@ -385,22 +441,44 @@ type var Abort: boolean); override; end; - { TPasProcedureScope } - - TPasProcedureScope = Class(TPasIdentifierScope) - end; - { TPasRecordScope } TPasRecordScope = Class(TPasIdentifierScope) end; + { TPasClassScope } + + TPasClassScope = Class(TPasIdentifierScope) + public + AncestorResolved: boolean; + AncestorScope: TPasClassScope; + DirectAncestor: TPasType; // TPasClassType or TPasAliasType or TPasTypeAliasType + function FindIdentifier(const Identifier: String): TPasIdentifier; override; + procedure IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); override; + end; + + { TPasProcedureScope } + + TPasProcedureScope = Class(TPasIdentifierScope) + public + DeclarationProc: TPasProcedure; // the corresponding forward declaration + ImplProc: TPasProcedure; // the corresponding proc with Body + OverriddenProc: TPasProcedure; // if IsOverride then this is the ancestor proc (virtual or override) + ClassScope: TPasClassScope; + function FindIdentifier(const Identifier: String): TPasIdentifier; override; + procedure IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); override; + end; + { TPasExceptOnScope } TPasExceptOnScope = Class(TPasIdentifierScope) end; - { TPasSubScope - base class for sub scopes } + { TPasSubScope - base class for sub scopes aka dotted scopes } TPasSubScope = Class(TPasIdentifierScope) public @@ -434,9 +512,9 @@ type property CurModule: TPasModule read FCurModule write SetCurModule; end; - { TPasSubRecordScope } + { TPasDotRecordScope - used for aRecord.subidentifier } - TPasSubRecordScope = Class(TPasSubScope) + TPasDotRecordScope = Class(TPasSubScope) public RecordScope: TPasRecordScope; function FindIdentifier(const Identifier: String): TPasIdentifier; override; @@ -445,6 +523,17 @@ type var Abort: boolean); override; end; + { TPasDotClassScope - used for aClass.subidentifier } + + TPasDotClassScope = Class(TPasSubScope) + public + ClassScope: TPasClassScope; + function FindIdentifier(const Identifier: String): TPasIdentifier; override; + procedure IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); override; + end; + TPasResolvedKind = ( rkNone, rkIdentifier, // IdentEl is a type, var, const, property, proc, etc, built-in types have IdentEl=nil @@ -478,9 +567,12 @@ type FLastMsgType: TMessageType; FScopes: array of TPasScope; // stack of scopes FScopeCount: integer; + FSubScopes: array of TPasScope; // stack of scopes + FSubScopeCount: integer; FStoreSrcColumns: boolean; FRootElement: TPasElement; FTopScope: TPasScope; + FPendingForwards: TFPList; // list of TPasElement needed to check for forwards function GetScopes(Index: integer): TPasScope; inline; protected type @@ -492,21 +584,33 @@ type procedure OnFindFirstElement(El: TPasElement; Scope: TPasScope; FindFirstElementData: Pointer; var Abort: boolean); virtual; protected + const + cIncompatible = High(integer); + cExact = 0; type - TProcCompatibility = ( - pcIncompatible, - pcCompatible, // e.g. assign a longint to an int64 - pcExact - ); - TFindProcsData = record + TFindCallProcData = record Params: TParamsExpr; Found: TPasProcedure; - Compatible: TProcCompatibility; + Distance: integer; // compatibility distance Count: integer; + List: TFPList; // if not nil then collect all found proc here end; - PFindProcsData = ^TFindProcsData; - procedure OnFindProc(El: TPasElement; Scope: TPasScope; + PFindCallProcData = ^TFindCallProcData; + + TFindOverloadProcData = record + Proc: TPasProcedure; + Args: TFPList; // List of TPasArgument objects + OnlyScope: TPasScope; + Found: TPasProcedure; + FoundInScope: TPasScope; + FoundNonProc: TPasElement; + end; + PFindOverloadProcData = ^TFindOverloadProcData; + + procedure OnFindCallProc(El: TPasElement; Scope: TPasScope; FindProcsData: Pointer; var Abort: boolean); virtual; + procedure OnFindOverloadProc(El: TPasElement; Scope: TPasScope; + FindOverloadData: Pointer; var Abort: boolean); virtual; protected procedure SetCurrentParser(AValue: TPasParser); override; procedure CheckTopScope(ExpectedClass: TPasScopeClass); @@ -517,7 +621,9 @@ type procedure AddSection(El: TPasSection); procedure AddType(El: TPasType); Procedure AddRecordType(El: TPasRecordType); + Procedure AddClassType(El: TPasClassType); procedure AddVariable(El: TPasVariable); + procedure AddProperty(El: TPasProperty); procedure AddProcedure(El: TPasProcedure); procedure AddArgument(El: TPasArgument); procedure AddFunctionResult(El: TPasResultElement); @@ -525,21 +631,30 @@ type procedure StartProcedureBody(El: TProcedureBody); procedure FinishModule(CurModule: TPasModule); procedure FinishUsesList; - procedure FinishTypeSection; + procedure FinishTypeSection(El: TPasDeclarations); procedure FinishTypeDef(El: TPasType); procedure FinishProcedure; - procedure FinishProcedureHeader; + procedure FinishProcedureHeader(El: TPasProcedureType); + procedure FinishMethodDeclHeader(Proc: TPasProcedure); + procedure FinishMethodImplHeader(ImplProc: TPasProcedure); + procedure CheckProcSignatureMatch(DeclProc, ImplProc: TPasProcedure); procedure FinishExceptOnExpr; procedure FinishExceptOnStatement; + procedure FinishDeclaration(El: TPasElement); + procedure FinishPropertyOfClass(PropEl: TPasProperty); + procedure FinishAncestors(aClass: TPasClassType); procedure ResolveImplBlock(Block: TPasImplBlock); procedure ResolveImplElement(El: TPasImplElement); procedure ResolveImplCaseOf(CaseOf: TPasImplCaseOf); procedure ResolveImplLabelMark(Mark: TPasImplLabelMark); procedure ResolveImplForLoop(Loop: TPasImplForLoop); procedure ResolveExpr(El: TPasExpr); + procedure ResolveInherited(El: TInheritedExpr); + procedure ResolveInheritedCall(El: TBinaryExpr); procedure ResolveBinaryExpr(El: TBinaryExpr); procedure ResolveSubIdent(El: TBinaryExpr); procedure ResolveParamsExpr(Params: TParamsExpr); + procedure CheckPendingForwards(El: TPasElement); procedure WriteScopes; public constructor Create; @@ -563,25 +678,41 @@ type class function GetElementSourcePosStr(El: TPasElement): string; procedure Clear; virtual; procedure AddObjFPCBuiltInIdentifiers(BaseTypes: TResolveBaseTypes = btAllStandardTypes); + function IsBaseType(aType: TPasType; BaseType: TResolveBaseType): boolean; function CreateReference(DeclEl, RefEl: TPasElement): TResolvedReference; virtual; function CreateScope(El: TPasElement; ScopeClass: TPasScopeClass): TPasScope; virtual; procedure PopScope; procedure PushScope(Scope: TPasScope); overload; function PushScope(El: TPasElement; ScopeClass: TPasScopeClass): TPasScope; inline; overload; + function PushDotClassScope(var CurClassType: TPasClassType): TPasDotClassScope; + procedure ResetSubScopes(out Depth: integer); + procedure RestoreSubScopes(Depth: integer); procedure SetLastMsg(MsgType: TMessageType; MsgNumber: integer; Const Fmt : String; Args : Array of const; Element: TPasElement); + procedure LogMsg(MsgType: TMessageType; MsgNumber: integer; + const Fmt: String; Args: Array of const; PosEl: TPasElement); overload; procedure RaiseMsg(MsgNumber: integer; const Fmt: String; Args: Array of const; ErrorPosEl: TPasElement); procedure RaiseNotYetImplemented(El: TPasElement; Msg: string = ''); virtual; procedure RaiseInternalError(const Msg: string); procedure RaiseInvalidScopeForElement(El: TPasElement; const Msg: string = ''); procedure RaiseIdentifierNotFound(Identifier: string; El: TPasElement); - function CheckProcCompatibility(Proc: TPasProcedure; - Params: TParamsExpr; RaiseOnError: boolean): TProcCompatibility; + procedure RaiseXExpectedButYFound(X,Y: string; El: TPasElement); + function CheckCallProcCompatibility(Proc: TPasProcedure; + Params: TParamsExpr; RaiseOnError: boolean): integer; function CheckParamCompatibility(Expr: TPasExpr; Param: TPasArgument; - ParamNo: integer; RaiseOnError: boolean): TProcCompatibility; + ParamNo: integer; RaiseOnError: boolean): integer; + function CheckCustomTypeCompatibility( + const SrcType, DestType: TPasResolvedType; ErrorEl: TPasElement): integer; + function CheckSrcIsADstType( + const ResolvedSrcType, ResolvedDestType: TPasResolvedType; + ErrorEl: TPasElement): integer; + function CheckOverloadProcCompatibility(Proc1, Proc2: TPasProcedure): boolean; + function CheckProcArgCompatibility(Proc1, Proc2: TPasProcedure; + ArgNo: integer): boolean; procedure GetResolvedType(El: TPasElement; SkipTypeAlias: boolean; out ResolvedType: TPasResolvedType); + function GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType; public property LastElement: TPasElement read FLastElement; property StoreSrcColumns: boolean read FStoreSrcColumns write FStoreSrcColumns; { @@ -610,6 +741,7 @@ procedure SetResolvedType(out ResolvedType: TPasResolvedType; TypeEl: TPasType); overload; procedure SetResolvedTypeExpr(out ResolvedType: TPasResolvedType; BaseType: TResolveBaseType; ExprEl: TPasExpr); overload; +function ProcNeedsImplProc(Proc: TPasProcedure): boolean; implementation @@ -834,15 +966,86 @@ begin ResolvedType.ExprEl:=ExprEl; end; -{ TPasSubRecordScope } +function ProcNeedsImplProc(Proc: TPasProcedure): boolean; +begin + Result:=true; + if Proc.IsExternal then exit(false); + if Proc.IsForward then exit; + if Proc.Parent.ClassType=TInterfaceSection then exit; + if Proc.Parent.ClassType=TPasClassType then + begin + // a method declaration + if not Proc.IsAbstract then exit; + end; + Result:=false; +end; -function TPasSubRecordScope.FindIdentifier(const Identifier: String +{ TPasProcedureScope } + +function TPasProcedureScope.FindIdentifier(const Identifier: String + ): TPasIdentifier; +begin + Result:=inherited FindIdentifier(Identifier); + if Result<>nil then exit; + if ClassScope<>nil then + Result:=ClassScope.FindIdentifier(Identifier); +end; + +procedure TPasProcedureScope.IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); +begin + inherited IterateElements(aName, OnIterateElement, Data, Abort); + if Abort then exit; + if ClassScope<>nil then + ClassScope.IterateElements(aName, OnIterateElement, Data, Abort); +end; + +{ TPasClassScope } + +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; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); +begin + inherited IterateElements(aName, OnIterateElement, Data, Abort); + if Abort then exit; + if AncestorScope<>nil then + AncestorScope.IterateElements(aName,OnIterateElement,Data,Abort); +end; + +{ TPasDotClassScope } + +function TPasDotClassScope.FindIdentifier(const Identifier: String + ): TPasIdentifier; +begin + Result:=ClassScope.FindIdentifier(Identifier); +end; + +procedure TPasDotClassScope.IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); +begin + ClassScope.IterateElements(aName, OnIterateElement, Data, Abort); +end; + +{ TPasDotRecordScope } + +function TPasDotRecordScope.FindIdentifier(const Identifier: String ): TPasIdentifier; begin Result:=RecordScope.FindIdentifier(Identifier); end; -procedure TPasSubRecordScope.IterateElements(const aName: string; +procedure TPasDotRecordScope.IterateElements(const aName: string; const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); begin @@ -1119,12 +1322,12 @@ begin if Scope=nil then ; end; -procedure TPasResolver.OnFindProc(El: TPasElement; Scope: TPasScope; +procedure TPasResolver.OnFindCallProc(El: TPasElement; Scope: TPasScope; FindProcsData: Pointer; var Abort: boolean); var - Data: PFindProcsData absolute FindProcsData; - Proc: TPasProcedure; - Compatible: TProcCompatibility; + Data: PFindCallProcData absolute FindProcsData; + Proc, OldProc: TPasProcedure; + Distance: integer; begin if not (El is TPasProcedure) then begin @@ -1138,22 +1341,94 @@ begin end else exit; - end; + end; // identifier is a proc {$IFDEF VerbosePasResolver} - writeln('TPasResolver.OnFindProc ',GetTreeDesc(El,2)); + writeln('TPasResolver.OnFindCallProc ',GetTreeDesc(El,2)); {$ENDIF} Proc:=TPasProcedure(El); if Scope=nil then ; - Compatible:=CheckProcCompatibility(Proc,Data^.Params,false); - if (Data^.Found=nil) or (ord(Compatible)>ord(Data^.Compatible)) then + Distance:=CheckCallProcCompatibility(Proc,Data^.Params,false); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.OnFindCallProc Compatible=',Distance,' Data^.Found=',Data^.Found<>nil,' Data^.Compatible=',ord(Data^.Distance)); + {$ENDIF} + + if Data^.Found<>nil then + begin + // check if found proc and old found proc are 'forward' and 'body' + OldProc:=Data^.Found; + if ProcNeedsImplProc(Proc) and (Proc.CustomData is TPasProcedureScope) + and (TPasProcedureScope(Proc.CustomData).ImplProc=OldProc) + then + exit; + if ProcNeedsImplProc(OldProc) and (OldProc.CustomData is TPasProcedureScope) + and (TPasProcedureScope(OldProc.CustomData).ImplProc=Proc) + then + begin + Data^.Found:=Proc; + exit; + end; + end; + + if (Data^.Found=nil) or (Distance normal when searching for overloads + + //writeln('TPasResolver.OnFindOverloadProc Data^.OnlyScope=',GetObjName(Data^.OnlyScope),' Scope=',GetObjName(Scope),' ',Data^.OnlyScope=Scope); + if (Data^.OnlyScope<>nil) and (Data^.OnlyScope<>Scope) 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 ',GetTreeDesc(El,2)); + {$ENDIF} + Proc:=TPasProcedure(El); + if CheckOverloadProcCompatibility(Data^.Proc,Proc) then begin Data^.Found:=Proc; - Data^.Compatible:=Compatible; - Data^.Count:=1; - end - else if Compatible=Data^.Compatible then - inc(Data^.Count); + Data^.FoundInScope:=Scope; + Abort:=true; + end; end; procedure TPasResolver.SetCurrentParser(AValue: TPasParser); @@ -1163,7 +1438,8 @@ begin Clear; inherited SetCurrentParser(AValue); if CurrentParser<>nil then - CurrentParser.Options:=CurrentParser.Options+[po_resolvestandardtypes]; + CurrentParser.Options:=CurrentParser.Options + +[po_resolvestandardtypes,po_nooverloadedprocs]; end; procedure TPasResolver.CheckTopScope(ExpectedClass: TPasScopeClass); @@ -1193,6 +1469,7 @@ end; procedure TPasResolver.FinishModule(CurModule: TPasModule); var CurModuleClass: TClass; + i: Integer; begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.FinishModule START ',CurModule.Name); @@ -1207,18 +1484,18 @@ begin begin if CurModule.FinalizationSection<>nil then // finalization section finished -> resolve - ResolveImplBlock(CurModule.FinalizationSection) - else if CurModule.InitializationSection<>nil then + ResolveImplBlock(CurModule.FinalizationSection); + if CurModule.InitializationSection<>nil then // initialization section finished -> resolve - ResolveImplBlock(CurModule.InitializationSection) - else - begin - // ToDo: check if all forward procs are implemented - end; + ResolveImplBlock(CurModule.InitializationSection); end else RaiseInternalError(''); // unknown module + // check all methods have bodies + for i:=0 to FPendingForwards.Count-1 do + CheckPendingForwards(TPasElement(FPendingForwards[i])); + // close all sections while (TopScope<>nil) and (TopScope.ClassType=TPasSectionScope) do PopScope; @@ -1252,6 +1529,7 @@ begin if (El.ClassType=TProgramSection) then RaiseInternalError('used unit is a program: '+GetObjName(El)); + // add unitname as identifier AddIdentifier(Scope,El.Name,El,pikSimple); // check used unit @@ -1274,9 +1552,21 @@ begin end; end; -procedure TPasResolver.FinishTypeSection; +procedure TPasResolver.FinishTypeSection(El: TPasDeclarations); +var + i: Integer; + Decl: TPasElement; begin // ToDo: resolve pending forwards + for i:=0 to El.Declarations.Count-1 do + begin + Decl:=TPasElement(El.Declarations[i]); + if Decl is TPasClassType then + begin + if TPasClassType(Decl).IsForward and (TPasClassType(Decl).CustomData=nil) then + RaiseMsg(nForwardTypeNotResolved,sForwardTypeNotResolved,[Decl.Name],Decl); + end; + end; end; procedure TPasResolver.FinishTypeDef(El: TPasType); @@ -1286,7 +1576,8 @@ begin {$ENDIF} if TopScope.Element=El then begin - if TopScope.ClassType=TPasRecordScope then + if (TopScope.ClassType=TPasRecordScope) + or (TopScope.ClassType=TPasClassScope) then PopScope; end; end; @@ -1294,22 +1585,340 @@ end; procedure TPasResolver.FinishProcedure; var aProc: TPasProcedure; + i: Integer; + Body: TProcedureBody; + SubEl: TPasElement; + SubProcScope: TPasProcedureScope; begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.FinishProcedure START'); {$ENDIF} CheckTopScope(TPasProcedureScope); aProc:=TPasProcedureScope(TopScope).Element as TPasProcedure; - if aProc.Body<>nil then - ResolveImplBlock(aProc.Body.Body); + Body:=aProc.Body; + if Body<>nil then + begin + ResolveImplBlock(Body.Body); + + // check if all forward procs are resolved + for i:=0 to Body.Declarations.Count-1 do + begin + SubEl:=TPasElement(Body.Declarations[i]); + if (SubEl is TPasProcedure) and TPasProcedure(SubEl).IsForward then + begin + SubProcScope:=TPasProcedure(SubEl).CustomData as TPasProcedureScope; + if SubProcScope.ImplProc=nil then + RaiseMsg(nForwardProcNotResolved,sForwardProcNotResolved, + [SubEl.ElementTypeName,SubEl.Name],SubEl); + end; + end; + end; PopScope; end; -procedure TPasResolver.FinishProcedureHeader; +procedure TPasResolver.FinishProcedureHeader(El: TPasProcedureType); +var + ProcName: String; + p: SizeInt; + FindData: TFindOverloadProcData; + DeclProc, Proc: TPasProcedure; + Abort: boolean; + DeclProcScope, ProcScope: TPasProcedureScope; + FoundInScope: TPasIdentifierScope; begin CheckTopScope(TPasProcedureScope); - // ToDo: check class - // ToDo: check duplicate + + // search the best fitting proc + if El.Parent is TPasProcedure then + begin + Proc:=TPasProcedure(El.Parent); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishProcedureHeader El=',GetTreeDesc(El),' ',GetElementSourcePosStr(El),' IsForward=',Proc.IsForward,' Parent=',GetObjName(El.Parent)); + {$ENDIF} + ProcName:=Proc.Name; + + if Proc.IsForward and Proc.IsExternal then + RaiseMsg(nInvalidProcModifiers, + sInvalidProcModifiers,[Proc.ElementTypeName,'forward, external'],Proc); + + if Proc.IsDynamic then + // 'dynamic' is not supported + RaiseMsg(nInvalidProcModifiers,sInvalidProcModifiers,[Proc.ElementTypeName,'dynamic'],Proc); + + if Proc.Parent is TPasClassType then + begin + // method declaration + if Proc.IsAbstract then + begin + if not Proc.IsVirtual then + RaiseMsg(nInvalidProcModifiers,sInvalidProcModifiers,[Proc.ElementTypeName,'abstract without virtual'],Proc); + if Proc.IsOverride then + RaiseMsg(nInvalidProcModifiers,sInvalidProcModifiers,[Proc.ElementTypeName,'abstract, override'],Proc); + end; + if Proc.IsVirtual and Proc.IsOverride then + RaiseMsg(nInvalidProcModifiers,sInvalidProcModifiers,[Proc.ElementTypeName,'virtual, override'],Proc); + if Proc.IsForward then + RaiseMsg(nInvalidProcModifiers,sInvalidProcModifiers,[Proc.ElementTypeName,'forward'],Proc); + end + else + begin + // intf proc, forward proc, proc body, method body + if Proc.IsAbstract then + RaiseMsg(nInvalidProcModifiers,sInvalidProcModifiers,[Proc.ElementTypeName,'abstract'],Proc); + if Proc.IsVirtual then + RaiseMsg(nInvalidProcModifiers,sInvalidProcModifiers,[Proc.ElementTypeName,'virtual'],Proc); + if Proc.IsOverride then + RaiseMsg(nInvalidProcModifiers,sInvalidProcModifiers,[Proc.ElementTypeName,'override'],Proc); + if Proc.IsMessage then + RaiseMsg(nInvalidProcModifiers,sInvalidProcModifiers,[Proc.ElementTypeName,'message'],Proc); + if Proc.IsStatic then + RaiseMsg(nInvalidProcModifiers,sInvalidProcModifiers,[Proc.ElementTypeName,'static'],Proc); + end; + + p:=Pos('.',ProcName); + if p>1 then + begin + FinishMethodImplHeader(Proc); + exit; + end; + + // finish non method, i.e. interface/implementation/nested procedure/method declaration + if not IsValidIdent(ProcName) then + RaiseNotYetImplemented(El); + + if Proc.Parent is TPasClassType then + begin + FinishMethodDeclHeader(Proc); + exit; + end; + + FindData:=Default(TFindOverloadProcData); + FindData.Proc:=Proc; + FindData.Args:=Proc.ProcType.Args; + Abort:=false; + IterateElements(ProcName,@OnFindOverloadProc,@FindData,Abort); + if FindData.FoundNonProc<>nil then + begin + // proc hides a non proc -> forbidden within module + if (Proc.GetModule=FindData.FoundNonProc.GetModule) then + RaiseMsg(nDuplicateIdentifier,sDuplicateIdentifier, + [FindData.FoundNonProc.Name,GetElementSourcePosStr(FindData.FoundNonProc)],Proc.ProcType); + end; + if FindData.Found=nil then + exit; // no overload -> ok + + // overload found + DeclProc:=FindData.Found; + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishProcedureHeader overload found: Proc2=',GetTreeDesc(DeclProc),' ',GetElementSourcePosStr(DeclProc),' IsForward=',DeclProc.IsForward,' Parent=',GetObjName(DeclProc.Parent)); + {$ENDIF} + if (Proc.Parent=DeclProc.Parent) + or ((Proc.Parent is TImplementationSection) + and (DeclProc.Parent is TInterfaceSection) + and (Proc.Parent.Parent=DeclProc.Parent.Parent)) + then + begin + // both procs are defined in the same scope + if ProcNeedsImplProc(Proc) or (not ProcNeedsImplProc(DeclProc)) then + RaiseMsg(nDuplicateIdentifier,sDuplicateIdentifier, + [ProcName,GetElementSourcePosStr(DeclProc)],Proc.ProcType); + CheckProcSignatureMatch(DeclProc,Proc); + DeclProcScope:=DeclProc.CustomData as TPasProcedureScope; + DeclProcScope.ImplProc:=Proc; + ProcScope:=Proc.CustomData as TPasProcedureScope; + ProcScope.DeclarationProc:=DeclProc; + // remove DeclProc from scope + FoundInScope:=FindData.FoundInScope as TPasIdentifierScope; + FoundInScope.RemoveIdentifier(DeclProc); + end + else + begin + // give a hint, that proc is hiding DeclProc + LogMsg(mtHint,nFunctionHidesIdentifier,sFunctionHidesIdentifier, + [DeclProc.Name,GetElementSourcePosStr(DeclProc)],Proc.ProcType); + end; + end + else + RaiseNotYetImplemented(El.Parent); +end; + +procedure TPasResolver.FinishMethodDeclHeader(Proc: TPasProcedure); +var + Abort: boolean; + ClassScope: TPasClassScope; + FindData: TFindOverloadProcData; + OverloadProc: TPasProcedure; + ProcScope: TPasProcedureScope; +begin + ProcScope:=TopScope as TPasProcedureScope; + ClassScope:=Scopes[ScopeCount-2] as TPasClassScope; + FindData:=Default(TFindOverloadProcData); + FindData.Proc:=Proc; + FindData.Args:=Proc.ProcType.Args; + Abort:=false; + ClassScope.IterateElements(Proc.Name,@OnFindOverloadProc,@FindData,Abort); + if FindData.FoundNonProc<>nil then + // proc hides a non proc -> duplicate + RaiseMsg(nDuplicateIdentifier,sDuplicateIdentifier, + [FindData.FoundNonProc.Name,GetElementSourcePosStr(FindData.FoundNonProc)],Proc.ProcType); + if FindData.Found=nil then + begin + // no overload + if Proc.IsOverride then + RaiseMsg(nNoMethodInAncestorToOverride, + sNoMethodInAncestorToOverride,[GetProcDesc(Proc)],Proc.ProcType); + end + else + begin + // overload found + OverloadProc:=FindData.Found; + if Proc.Parent=OverloadProc.Parent then + // overload in same scope -> duplicate + RaiseMsg(nDuplicateIdentifier,sDuplicateIdentifier, + [OverloadProc.Name,GetElementSourcePosStr(OverloadProc)],Proc.ProcType); + ProcScope.OverriddenProc:=OverloadProc; + if Proc.IsOverride then + begin + if (not OverloadProc.IsVirtual) and (not OverloadProc.IsOverride) then + // the OverloadProc fits the signature, but is not virtual + RaiseMsg(nNoMethodInAncestorToOverride, + sNoMethodInAncestorToOverride,[GetProcDesc(Proc)],Proc.ProcType); + // override a virtual method + CheckProcSignatureMatch(OverloadProc,Proc); + end + else if not Proc.IsReintroduced then + begin + // give a hint, that proc is hiding OverloadProc + LogMsg(mtHint,nFunctionHidesIdentifier,sFunctionHidesIdentifier, + [OverloadProc.Name,GetElementSourcePosStr(OverloadProc)],Proc.ProcType); + end; + end; +end; + +procedure TPasResolver.FinishMethodImplHeader(ImplProc: TPasProcedure); +var + p: SizeInt; + ProcName, aClassName: String; + CurClassType: TPasClassType; + OldScopeCount: Integer; + FindData: TFindOverloadProcData; + Abort: boolean; + ImplProcScope, DeclProcScope: TPasProcedureScope; + DeclProc: TPasProcedure; + CurClassScope: TPasClassScope; +begin + // search class + ProcName:=ImplProc.Name; + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishMethodBodyHeader searching declaration "',ProcName,'" ...'); + {$ENDIF} + OldScopeCount:=ScopeCount; + CurClassType:=nil; + repeat + p:=Pos('.',ProcName); + if p<1 then + begin + if CurClassType=nil then + RaiseInternalError(''); + break; + end; + aClassName:=LeftStr(ProcName,p-1); + Delete(ProcName,1,p); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishMethodBodyHeader searching class "',aClassName,'" ProcName="',ProcName,'" ...'); + {$ENDIF} + if not IsValidIdent(aClassName) then + RaiseNotYetImplemented(ImplProc.ProcType); + + if CurClassType<>nil then + PushDotClassScope(CurClassType); + + CurClassType:=TPasClassType(FindFirstElement(aClassName,ImplProc.ProcType)); + if not (CurClassType is TPasClassType) then + begin + aClassName:=LeftStr(ImplProc.Name,length(ImplProc.Name)-length(ProcName)); + RaiseXExpectedButYFound('class',aClassname+':'+CurClassType.ElementTypeName,ImplProc.ProcType); + end; + + // restore scope + if ScopeCount>OldScopeCount then + PopScope; + until false; + + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishMethodBodyHeader searching proc "',ProcName,'" ...'); + {$ENDIF} + // search ImplProc in class + if not IsValidIdent(ProcName) then + RaiseNotYetImplemented(ImplProc.ProcType); + + CurClassScope:=CurClassType.CustomData as TPasClassScope; + FindData:=Default(TFindOverloadProcData); + FindData.Proc:=ImplProc; + FindData.Args:=ImplProc.ProcType.Args; + FindData.OnlyScope:=CurClassScope; + Abort:=false; + CurClassScope.IterateElements(ProcName,@OnFindOverloadProc,@FindData,Abort); + if FindData.Found=nil then + RaiseIdentifierNotFound(ImplProc.Name,ImplProc.ProcType); + + // connect method declaration and body + DeclProc:=FindData.Found; + if DeclProc.IsAbstract then + RaiseMsg(nAbstractMethodsMustNotHaveImplementation,sAbstractMethodsMustNotHaveImplementation,[],ImplProc); + if DeclProc.IsExternal then + RaiseXExpectedButYFound('method','external method',ImplProc); + CheckProcSignatureMatch(DeclProc,ImplProc); + //or DeclProc.IsExternal then; + ImplProcScope:=ImplProc.CustomData as TPasProcedureScope; + ImplProcScope.DeclarationProc:=DeclProc; + ImplProcScope.ClassScope:=CurClassScope; + DeclProcScope:=DeclProc.CustomData as TPasProcedureScope; + DeclProcScope.ImplProc:=ImplProc; + + // add 'Self' + AddIdentifier(ImplProcScope,'Self',CurClassType,pikSimple); + + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishMethodBodyHeader END of searching proc "',ImplProc.Name,'" ...'); + {$ENDIF} +end; + +procedure TPasResolver.CheckProcSignatureMatch(DeclProc, ImplProc: TPasProcedure + ); +var + i: Integer; + DeclArgs, ImplArgs: TFPList; + DeclName, ImplName: String; + ImplResult, DeclResult: TPasType; +begin + if ImplProc.ClassType<>DeclProc.ClassType then + RaiseXExpectedButYFound(DeclProc.TypeName,ImplProc.TypeName,ImplProc); + if ImplProc.CallingConvention<>DeclProc.CallingConvention then + RaiseMsg(nCallingConventionMismatch,sCallingConventionMismatch,[],ImplProc); + if ImplProc is TPasFunction then + begin + // check result type + ImplResult:=TPasFunction(ImplProc).FuncType.ResultEl.ResultType; + DeclResult:=TPasFunction(DeclProc).FuncType.ResultEl.ResultType; + if (ImplResult=nil) + or (ImplResult<>DeclResult) then + RaiseMsg(nResultTypeMismatchExpectedButFound, + sResultTypeMismatchExpectedButFound,[GetTypeDesc(DeclResult),GetTypeDesc(ImplResult)], + ImplProc); + end; + + // check argument names + DeclArgs:=DeclProc.ProcType.Args; + ImplArgs:=ImplProc.ProcType.Args; + for i:=0 to DeclArgs.Count-1 do + begin + DeclName:=TPasArgument(DeclArgs[i]).Name; + ImplName:=TPasArgument(ImplArgs[i]).Name; + if CompareText(DeclName,ImplName)<>0 then + RaiseMsg(nFunctionHeaderMismatchForwardVarName, + sFunctionHeaderMismatchForwardVarName,[DeclProc.Name,DeclName,ImplName],ImplProc); + end; end; procedure TPasResolver.FinishExceptOnExpr; @@ -1322,7 +1931,7 @@ begin if El.VarExpr<>nil then begin if El.VarExpr.ClassType<>TPrimitiveExpr then - RaiseNotYetImplemented(El.VarExpr); + RaiseNotYetImplemented(El.VarExpr,'FinishExceptOnExpr'); Expr:=TPrimitiveExpr(El.VarExpr); if Expr.Kind<>pekIdent then RaiseNotYetImplemented(Expr); @@ -1340,6 +1949,265 @@ begin PopScope; end; +procedure TPasResolver.FinishDeclaration(El: TPasElement); +begin + if El.ClassType=TPasProperty then + FinishPropertyOfClass(TPasProperty(El)); +end; + +procedure TPasResolver.FinishPropertyOfClass(PropEl: TPasProperty); +var + PropType, ResultType: TPasType; + CurClassType: TPasClassType; + ClassScope: TPasClassScope; + AccEl: TPasElement; + Proc: TPasProcedure; + ArgCount: Integer; + Arg: TPasArgument; + + procedure GetPropType; + var + AncProp: TPasIdentifier; + begin + if PropType<>nil then exit; + if PropEl.VarType<>nil then + PropType:=PropEl.VarType + else + begin + // search property in ancestor + AncProp:=nil; + if ClassScope.AncestorScope<>nil then + AncProp:=ClassScope.AncestorScope.FindIdentifier(PropEl.Name); + if (AncProp=nil) or (not (AncProp.Element is TPasProperty)) then + RaiseMsg(nNoPropertyFoundToOverride,sNoPropertyFoundToOverride,[],PropEl); + PropType:=TPasProperty(AncProp.Element).VarType; + CreateReference(AncProp.Element,PropEl); + end; + end; + + function GetAccessor(Expr: TPasExpr): TPasElement; + var + Prim: TPrimitiveExpr; + DeclEl: TPasElement; + begin + repeat + if Expr.ClassType=TBinaryExpr then + begin + if TBinaryExpr(Expr).left is TPrimitiveExpr then + begin + Prim:=TPrimitiveExpr(TBinaryExpr(Expr).left); + if Prim.CustomData is TResolvedReference then + begin + DeclEl:=TResolvedReference(Prim.CustomData).Declaration; + if DeclEl.ClassType<>TPasVariable then + RaiseXExpectedButYFound('var',DeclEl.ElementTypeName,Prim); + end; + end + else + RaiseNotYetImplemented(TBinaryExpr(Expr).left); + Expr:=TBinaryExpr(Expr).right + end + else if Expr.ClassType=TPrimitiveExpr then + begin + Prim:=TPrimitiveExpr(Expr); + if Prim.CustomData is TResolvedReference then + begin + Result:=TResolvedReference(Prim.CustomData).Declaration; + exit; + end + else + RaiseNotYetImplemented(Expr); + end + else + RaiseNotYetImplemented(Expr); + until false; + end; + +begin + PropType:=nil; + CurClassType:=PropEl.Parent as TPasClassType; + ClassScope:=CurClassType.CustomData as TPasClassScope; + GetPropType; + if PropEl.IndexExpr<>nil then + begin + ResolveExpr(PropEl.IndexExpr); + RaiseNotYetImplemented(PropEl.IndexExpr); + end; + if PropEl.ReadAccessor<>nil then + begin + // read accessor + ResolveExpr(PropEl.ReadAccessor); + // check compatibility + AccEl:=GetAccessor(PropEl.ReadAccessor); + if AccEl is TPasVariable then + begin + if TPasVariable(AccEl).VarType<>PropType then + RaiseXExpectedButYFound(GetTypeDesc(PropType), + GetTypeDesc(TPasVariable(AccEl).VarType),PropEl.ReadAccessor); + end + else if AccEl is TPasProcedure then + begin + // check function + Proc:=TPasProcedure(AccEl); + if Proc.ClassType<>TPasFunction then + RaiseXExpectedButYFound('function',Proc.ElementTypeName,PropEl.ReadAccessor); + // check function result type + ResultType:=TPasFunction(Proc).FuncType.ResultEl.ResultType; + if ResultType<>PropType then + RaiseXExpectedButYFound('function result '+GetTypeDesc(PropType), + GetTypeDesc(ResultType),PropEl.ReadAccessor); + // check arg count + ArgCount:=Proc.ProcType.Args.Count; + if Proc.ProcType.Args.Count<>0 then + RaiseXExpectedButYFound('function argument count '+IntToStr(0), + IntToStr(ArgCount),PropEl.ReadAccessor); + end + else + RaiseXExpectedButYFound('variable',AccEl.ElementTypeName,PropEl.ReadAccessor); + end; + if PropEl.WriteAccessor<>nil then + begin + // write accessor + ResolveExpr(PropEl.WriteAccessor); + // check compatibility + AccEl:=GetAccessor(PropEl.WriteAccessor); + if AccEl is TPasVariable then + begin + if TPasVariable(AccEl).VarType<>PropType then + RaiseXExpectedButYFound(GetTypeDesc(PropType), + GetTypeDesc(TPasVariable(AccEl).VarType),PropEl.WriteAccessor); + end + else if AccEl is TPasProcedure then + begin + // check procedure + Proc:=TPasProcedure(AccEl); + if Proc.ClassType<>TPasProcedure then + RaiseXExpectedButYFound('procedure',Proc.ElementTypeName,PropEl.WriteAccessor); + // check arg count + ArgCount:=Proc.ProcType.Args.Count; + if Proc.ProcType.Args.Count<>1 then + RaiseXExpectedButYFound('procedure argument count '+IntToStr(1), + IntToStr(ArgCount),PropEl.WriteAccessor); + Arg:=TPasArgument(Proc.ProcType.Args[0]); + if not (Arg.Access in [argDefault,argConst]) then + RaiseXExpectedButYFound('procedure(const Value)', + 'procedure('+AccessNames[Arg.Access]+' '+Arg.Name+')',PropEl.WriteAccessor); + if Arg.ArgType<>PropType then + RaiseXExpectedButYFound('procedure('+GetTypeDesc(PropType)+')', + 'procedure('+GetTypeDesc(Arg.ArgType)+')',PropEl.WriteAccessor); + end + else + RaiseXExpectedButYFound('variable',AccEl.ElementTypeName,PropEl.WriteAccessor); + end; + if PropEl.ImplementsFunc<>nil then + begin + ResolveExpr(PropEl.ImplementsFunc); + // ToDo: check compatibility + + end; + if PropEl.StoredAccessor<>nil then + begin + // stored accessor + ResolveExpr(PropEl.StoredAccessor); + // check compatibility + AccEl:=GetAccessor(PropEl.StoredAccessor); + if AccEl is TPasProcedure then + begin + // check function + Proc:=TPasProcedure(AccEl); + if Proc.ClassType<>TPasFunction then + RaiseXExpectedButYFound('function',Proc.ElementTypeName,PropEl.StoredAccessor); + // check function result type + ResultType:=TPasFunction(Proc).FuncType.ResultEl.ResultType; + if not IsBaseType(ResultType,btBoolean) then + RaiseXExpectedButYFound('function: boolean', + 'fucntion:'+GetTypeDesc(ResultType),PropEl.StoredAccessor); + // check arg count + ArgCount:=Proc.ProcType.Args.Count; + if Proc.ProcType.Args.Count<>0 then + RaiseXExpectedButYFound('function argument count '+IntToStr(0), + IntToStr(ArgCount),PropEl.StoredAccessor); + end + else + RaiseXExpectedButYFound('function: boolean',AccEl.ElementTypeName,PropEl.StoredAccessor); + end; + if PropEl.DefaultExpr<>nil then + begin + ResolveExpr(PropEl.DefaultExpr); + // ToDo: check compatibility + end; +end; + +procedure TPasResolver.FinishAncestors(aClass: TPasClassType); +// called when the ancestor and interface list of a class has been parsed, +// before parsing the class elements +var + AncestorEl: TPasClassType; + ClassScope: TPasClassScope; + DirectAncestor, AncestorType, El: TPasType; +begin + if aClass.IsForward then + exit; + + DirectAncestor:=aClass.AncestorType; + AncestorType:=DirectAncestor; + while (AncestorType<>nil) + and ((AncestorType.ClassType=TPasAliasType) or (AncestorType.ClassType=TPasTypeAliasType)) + do + AncestorType:=TPasAliasType(AncestorType).DestType; + + if AncestorType=nil then + begin + if CompareText(aClass.Name,'TObject')=0 then + begin + // ok, no ancestors + AncestorEl:=nil; + end else begin + // search default ancestor TObject + AncestorEl:=TPasClassType(FindFirstElement('TObject',aClass)); + if not (AncestorEl is TPasClassType) then + RaiseXExpectedButYFound('class type',GetObjName(AncestorEl),aClass); + end; + end + else if AncestorType.ClassType<>TPasClassType then + RaiseXExpectedButYFound('class type',GetTypeDesc(AncestorType),aClass) + else + AncestorEl:=TPasClassType(AncestorType); + if AncestorEl=nil then + begin + // root class TObject + end + else + begin + // inherited class -> check for cycle + if AncestorEl.IsForward then + RaiseMsg(nCantUseForwardDeclarationAsAncestor, + sCantUseForwardDeclarationAsAncestor,[AncestorEl.Name],aClass); + El:=AncestorEl; + repeat + if El=aClass then + RaiseMsg(nAncestorCycleDetected,sAncestorCycleDetected,[],aClass); + if (El.ClassType=TPasAliasType) + or (El.ClassType=TPasTypeAliasType) + then + El:=TPasAliasType(El).DestType + else if El.ClassType=TPasClassType then + El:=TPasClassType(El).AncestorType; + until El=nil; + end; + + // start scope for elements + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishAncestors ',GetObjName(aClass.CustomData)); + {$ENDIF} + PushScope(aClass,TPasClassScope); + ClassScope:=TPasClassScope(TopScope); + ClassScope.AncestorResolved:=true; + ClassScope.DirectAncestor:=DirectAncestor; + if AncestorEl<>nil then + ClassScope.AncestorScope:=AncestorEl.CustomData as TPasClassScope; +end; + procedure TPasResolver.ResolveImplBlock(Block: TPasImplBlock); var i: Integer; @@ -1486,17 +2354,106 @@ begin ResolveParamsExpr(TParamsExpr(El)) else if El.ClassType=TBoolConstExpr then else if El.ClassType=TNilExpr then + else if El.ClassType=TSelfExpr then + begin + DeclEl:=FindFirstElement('Self',El); + //writeln('TPasResolver.ResolveExpr Ref=',GetObjName(El)+' Decl='+GetObjName(DeclEl)); + CreateReference(DeclEl,El); + end + else if El.ClassType=TInheritedExpr then + ResolveInherited(TInheritedExpr(El)) else RaiseNotYetImplemented(El); end; +procedure TPasResolver.ResolveInherited(El: TInheritedExpr); +var + ProcScope, DeclProcScope: TPasProcedureScope; + AncestorScope: TPasClassScope; + DeclProc, AncestorProc: TPasProcedure; +begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.ResolveInheritedDefault El.Parent=',GetTreeDesc(El.Parent)); + {$ENDIF} + if (El.Parent.ClassType=TBinaryExpr) + and (TBinaryExpr(El.Parent).OpCode=eopNone) then + begin + ResolveInheritedCall(TBinaryExpr(El.Parent)); + exit; + end; + CheckTopScope(TPasProcedureScope); + ProcScope:=TPasProcedureScope(TopScope); + if ProcScope.ClassScope=nil then + RaiseMsg(nInheritedOnlyWorksInMethods,sInheritedOnlyWorksInMethods,[],El); + + AncestorScope:=ProcScope.ClassScope.AncestorScope; + if AncestorScope=nil then + begin + // 'inherited;' without ancestor is ignored + exit; + end; + + // search in ancestor + DeclProc:=ProcScope.DeclarationProc; + DeclProcScope:=DeclProc.CustomData as TPasProcedureScope; + AncestorProc:=DeclProcScope.OverriddenProc; + if AncestorProc<>nil then + CreateReference(AncestorProc,El) + else + begin + // 'inherited;' without ancestor is ignored + exit; + end; +end; + +procedure TPasResolver.ResolveInheritedCall(El: TBinaryExpr); +// El.OpCode=eopNone +// El.left is TInheritedExpr +// El.right is the identifier and parameters +var + ProcScope: TPasProcedureScope; + AncestorScope: TPasClassScope; + AncestorClass: TPasClassType; +begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.ResolveInheritedCall El=',GetTreeDesc(El)); + {$ENDIF} + CheckTopScope(TPasProcedureScope); + ProcScope:=TPasProcedureScope(TopScope); + if ProcScope.ClassScope=nil then + RaiseMsg(nInheritedOnlyWorksInMethods,sInheritedOnlyWorksInMethods,[],El); + + AncestorScope:=ProcScope.ClassScope.AncestorScope; + if AncestorScope=nil then + RaiseMsg(nInheritedNeedsAncestor,sInheritedNeedsAncestor,[],El.left); + + // search call in ancestor + AncestorClass:=TPasClassType(AncestorScope.Element); + PushDotClassScope(AncestorClass); + ResolveExpr(El.right); + PopScope; +end; + procedure TPasResolver.ResolveBinaryExpr(El: TBinaryExpr); begin //writeln('TPasResolver.ResolveBinaryExpr left=',GetObjName(El.left),' right=',GetObjName(El.right),' opcode=',OpcodeStrings[El.OpCode]); ResolveExpr(El.left); if El.right=nil then exit; case El.OpCode of - eopNone, + eopNone: + case El.Kind of + pekRange: + ResolveExpr(El.right); + else + if El.left.ClassType=TInheritedExpr then + else + begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.ResolveBinaryExpr El.Kind=',ExprKindNames[El.Kind],' El.Left=',GetObjName(El.left),' El.Right=',GetObjName(El.right),' parent=',GetObjName(El.Parent)); + {$ENDIF} + RaiseNotYetImplemented(El); + end; + end; eopAdd, eopSubtract, eopMultiply, @@ -1541,7 +2498,8 @@ var aModule: TPasModule; VarType: TPasType; RecScope: TPasRecordScope; - SubScope: TPasSubRecordScope; + SubScope: TPasSubScope; + CurClassType: TPasClassType; begin //writeln('TPasResolver.ResolveSubIdent El.left=',GetObjName(El.left)); if El.left.ClassType=TPrimitiveExpr then @@ -1593,14 +2551,22 @@ begin if VarType.ClassType=TPasRecordType then begin RecScope:=TPasRecordType(VarType).CustomData as TPasRecordScope; - SubScope:=TPasSubRecordScope.Create; + SubScope:=TPasDotRecordScope.Create; SubScope.Owner:=Self; - SubScope.RecordScope:=RecScope; + TPasDotRecordScope(SubScope).RecordScope:=RecScope; PushScope(SubScope); ResolveExpr(El.right); PopScope; exit; end + else if VarType.ClassType=TPasClassType then + begin + CurClassType:=TPasClassType(VarType); + PushDotClassScope(CurClassType); + ResolveExpr(El.right); + PopScope; + exit; + end else begin {$IFDEF VerbosePasResolver} @@ -1615,42 +2581,80 @@ begin writeln('TPasResolver.ResolveSubIdent DeclEl=',GetObjName(DeclEl)); {$ENDIF} end; + end + else if El.left.ClassType=TSelfExpr then + begin + if El.left.CustomData is TResolvedReference then + begin + DeclEl:=TResolvedReference(El.left.CustomData).Declaration; + if DeclEl.ClassType=TPasClassType then + begin + CurClassType:=TPasClassType(DeclEl); + PushDotClassScope(CurClassType); + ResolveExpr(El.right); + PopScope; + exit; + end + else + begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.ResolveSubIdent DeclEl=',GetObjName(DeclEl)); + {$ENDIF} + end; + end; end; RaiseMsg(nIllegalQualifier,sIllegalQualifier,['.'],El); end; procedure TPasResolver.ResolveParamsExpr(Params: TParamsExpr); var - i: Integer; - ProcName: String; - FindData: TFindProcsData; + i, ScopeDepth: Integer; + ProcName, Msg: String; + FindData: TFindCallProcData; Abort: boolean; begin // first resolve params + ResetSubScopes(ScopeDepth); for i:=0 to length(Params.Params)-1 do ResolveExpr(Params.Params[i]); + RestoreSubScopes(ScopeDepth); + // then search the best fitting proc if Params.Value.ClassType=TPrimitiveExpr then begin ProcName:=TPrimitiveExpr(Params.Value).Value; - FindData:=Default(TFindProcsData); + FindData:=Default(TFindCallProcData); FindData.Params:=Params; Abort:=false; - IterateElements(ProcName,@OnFindProc,@FindData,Abort); + IterateElements(ProcName,@OnFindCallProc,@FindData,Abort); if FindData.Found=nil then RaiseIdentifierNotFound(ProcName,Params.Value); - if FindData.Compatible=pcIncompatible then + if FindData.Distance=cIncompatible then begin // found one proc, but it was incompatible => raise error {$IFDEF VerbosePasResolver} writeln('TPasResolver.ResolveParamsExpr found one proc, but it was incompatible => check again to raise error'); {$ENDIF} - CheckProcCompatibility(FindData.Found,Params,true); + CheckCallProcCompatibility(FindData.Found,Params,true); end; if FindData.Count>1 then begin - // ToDo: multiple overloads fit => search again and list the candidates - RaiseMsg(nIdentifierNotFound,sIdentifierNotFound,[],Params.Value); + // multiple overloads fit => search again and list the candidates + FindData.List:=TFPList.Create; + try + IterateElements(ProcName,@OnFindCallProc,@FindData,Abort); + Msg:=''; + for i:=0 to FindData.List.Count-1 do + begin + // ToDo: create a hint for each candidate + Msg:=Msg+', '; + Msg:=Msg+GetElementSourcePosStr(TPasElement(FindData.List[i])); + end; + RaiseMsg(nCantDetermineWhichOverloadedFunctionToCall, + sCantDetermineWhichOverloadedFunctionToCall+Msg,[ProcName],Params.Value); + finally + FindData.List.Free; + end; end; // found compatible proc CreateReference(FindData.Found,Params.Value); @@ -1659,6 +2663,46 @@ begin RaiseNotYetImplemented(Params,'with parameters'); end; +procedure TPasResolver.CheckPendingForwards(El: TPasElement); +var + i: Integer; + DeclEl: TPasElement; + Proc: TPasProcedure; + aClassType: TPasClassType; +begin + if El is TPasDeclarations then + begin + for i:=0 to TPasDeclarations(El).Declarations.Count-1 do + begin + DeclEl:=TPasElement(TPasDeclarations(El).Declarations[i]); + if DeclEl is TPasProcedure then + begin + Proc:=TPasProcedure(DeclEl); + if ProcNeedsImplProc(Proc) + and (TPasProcedureScope(Proc.CustomData).ImplProc=nil) then + RaiseMsg(nForwardProcNotResolved,sForwardProcNotResolved, + [Proc.ElementTypeName,Proc.Name],Proc); + end; + end; + end + else if El is TPasClassType then + begin + aClassType:=TPasClassType(El); + for i:=0 to aClassType.Members.Count-1 do + begin + DeclEl:=TPasElement(aClassType.Members[i]); + if DeclEl is TPasProcedure then + begin + Proc:=TPasProcedure(DeclEl); + if Proc.IsAbstract then continue; + if TPasProcedureScope(Proc.CustomData).ImplProc=nil then + RaiseMsg(nForwardProcNotResolved,sForwardProcNotResolved, + [Proc.ElementTypeName,Proc.Name],Proc); + end; + end; + end; +end; + procedure TPasResolver.AddModule(El: TPasModule); begin if TopScope<>DefaultScope then @@ -1669,38 +2713,8 @@ end; procedure TPasResolver.AddSection(El: TPasSection); // TInterfaceSection, TImplementationSection, TProgramSection, TLibrarySection // Note: implementation scope is within the interface scope -var - CurModuleClass: TClass; begin - CurModuleClass:=CurrentParser.CurModule.ClassType; - if (CurModuleClass=TPasProgram) or (CurModuleClass=TPasLibrary) then - begin - if El.ClassType=TInitializationSection then - ; // ToDo: check if all forward procs are implemented - end - else if CurModuleClass=TPasModule then - begin - if El.ClassType=TInitializationSection then - begin - // finished implementation - // ToDo: check if all forward procs are implemented - end - else if El.ClassType=TFinalizationSection then - begin - if CurrentParser.CurModule.InitializationSection<>nil then - begin - // resolve initialization section - ResolveImplBlock(CurrentParser.CurModule.InitializationSection); - end - else - begin - // finished implementation - // ToDo: check if all forward procs are implemented - end; - end; - end - else - RaiseInternalError(''); // unknown module + FPendingForwards.Add(El); // check forward declarations at the end PushScope(El,TPasSectionScope); end; @@ -1723,13 +2737,56 @@ begin {$ENDIF} if not (TopScope is TPasIdentifierScope) then RaiseInvalidScopeForElement(El); - if El.Name<>'' then + if El.Name<>'' then begin AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple); + FPendingForwards.Add(El); // check forward declarations at the end + end; if El.Parent.ClassType<>TPasVariant then PushScope(El,TPasRecordScope); end; +procedure TPasResolver.AddClassType(El: TPasClassType); +var + Duplicate: TPasIdentifier; + ForwardDecl: TPasClassType; +begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.AddClassType ',GetObjName(El),' Parent=',GetObjName(El.Parent),' ',GetElementSourcePosStr(El)); + {$ENDIF} + if not (TopScope is TPasIdentifierScope) then + RaiseInvalidScopeForElement(El); + + Duplicate:=TPasIdentifierScope(TopScope).FindIdentifier(El.Name); + //if Duplicate<>nil then + //writeln(' Duplicate=',GetObjName(Duplicate.Element),' ',ord(Duplicate.Kind)); + + if (Duplicate<>nil) + and (Duplicate.Kind=pikSimple) + and (Duplicate.Element<>nil) + and (Duplicate.Element.Parent=El.Parent) + and (Duplicate.Element is TPasClassType) + and TPasClassType(Duplicate.Element).IsForward + then + begin + // forward declaration found + ForwardDecl:=TPasClassType(Duplicate.Element); + {$IFDEF VerbosePasResolver} + writeln(' Resolving Forward=',GetObjName(ForwardDecl),' ',GetElementSourcePosStr(ForwardDecl)); + {$ENDIF} + if ForwardDecl.CustomData<>nil then + RaiseInternalError('forward class has already customdata'); + // create a ref from the forward to the real declaration + CreateReference(El,ForwardDecl); + // change the cache item + Duplicate.Element:=El; + end + else + AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple); + + FPendingForwards.Add(El); // check forward declarations at the end +end; + procedure TPasResolver.AddVariable(El: TPasVariable); begin if (El.Name='') then exit; // anonymous var @@ -1741,6 +2798,18 @@ begin AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple); end; +procedure TPasResolver.AddProperty(El: TPasProperty); +begin + if (El.Name='') then + RaiseNotYetImplemented(El); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.AddProperty ',GetObjName(El)); + {$ENDIF} + if not (TopScope is TPasClassScope) then + RaiseInvalidScopeForElement(El); + AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple); +end; + procedure TPasResolver.AddProcedure(El: TPasProcedure); begin {$IFDEF VerbosePasResolver} @@ -1801,6 +2870,7 @@ constructor TPasResolver.Create; begin inherited Create; FDefaultScope:=TPasDefaultScope.Create; + FPendingForwards:=TFPList.Create; PushScope(FDefaultScope); end; @@ -1849,7 +2919,7 @@ begin begin if (ASrcPos.Column0) and (FTopScope<>DefaultScope) do PopScope; @@ -2015,6 +3092,15 @@ begin TPasUnresolvedSymbolRef.Create(BaseTypeNames[bt],nil),pikCustom); end; +function TPasResolver.IsBaseType(aType: TPasType; BaseType: TResolveBaseType + ): boolean; +begin + Result:=false; + if aType=nil then exit; + if aType.ClassType<>TPasUnresolvedSymbolRef then exit; + Result:=CompareText(aType.Name,BaseTypeNames[BaseType])=0; +end; + function TPasResolver.CreateReference(DeclEl, RefEl: TPasElement ): TResolvedReference; @@ -2107,8 +3193,72 @@ begin {$ENDIF} end; +function TPasResolver.PushDotClassScope(var CurClassType: TPasClassType + ): TPasDotClassScope; +var + ClassScope: TPasClassScope; + Ref: TResolvedReference; +begin + if CurClassType.IsForward then + begin + Ref:=CurClassType.CustomData as TResolvedReference; + CurClassType:=Ref.Declaration as TPasClassType; + end; + if CurClassType.CustomData=nil then + RaiseInternalError(''); + ClassScope:=CurClassType.CustomData as TPasClassScope; + Result:=TPasDotClassScope.Create; + Result.Owner:=Self; + Result.ClassScope:=ClassScope; + PushScope(Result); +end; + +procedure TPasResolver.ResetSubScopes(out Depth: integer); +// move all sub scopes from Scopes to SubScopes +begin + Depth:=FSubScopeCount; + while TopScope is TPasSubScope do + begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.ResetSubScopes moving ',TopScope.ClassName,' ScopeCount=',ScopeCount,' SubScopeCount=',FSubScopeCount); + {$ENDIF} + if FSubScopeCount=length(FSubScopes) then + SetLength(FSubScopes,FSubScopeCount+4); + FSubScopes[FSubScopeCount]:=TopScope; + inc(FSubScopeCount); + dec(FScopeCount); + FScopes[FScopeCount]:=nil; + if FScopeCount>0 then + FTopScope:=FScopes[FScopeCount-1] + else + FTopScope:=nil; + end; +end; + +procedure TPasResolver.RestoreSubScopes(Depth: integer); +// restore sub scopes +begin + while FSubScopeCount>Depth do + begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.RestoreSubScopes moving ',FSubScopes[FSubScopeCount-1].ClassName,' ScopeCount=',ScopeCount,' SubScopeCount=',FSubScopeCount); + {$ENDIF} + if FScopeCount=length(FScopes) then + SetLength(FScopes,FScopeCount+4); + dec(FSubScopeCount); + FScopes[FScopeCount]:=FSubScopes[FSubScopeCount]; + FTopScope:=FScopes[FScopeCount]; + FSubScopes[FSubScopeCount]:=nil; + inc(FScopeCount); + end; +end; + procedure TPasResolver.SetLastMsg(MsgType: TMessageType; MsgNumber: integer; const Fmt: String; Args: array of const; Element: TPasElement); +{$IFDEF VerbosePasResolver} +var + s: string; +{$ENDIF} begin FLastMsgType := MsgType; FLastMsgNumber := MsgNumber; @@ -2116,6 +3266,13 @@ begin FLastMsg := Format(Fmt,Args); FLastElement := Element; CreateMsgArgs(FLastMsgArgs,Args); + {$IFDEF VerbosePasResolver} + write('TPasResolver.SetLastMsg ',GetElementSourcePosStr(Element),' '); + s:=''; + str(MsgType,s); + write(s); + writeln(': [',MsgNumber,'] ',FLastMsg); + {$ENDIF} end; procedure TPasResolver.RaiseMsg(MsgNumber: integer; const Fmt: String; @@ -2137,7 +3294,7 @@ var begin s:=sNotYetImplemented; if Msg<>'' then - s:=s+Msg; + s:=s+' '+Msg; RaiseMsg(nNotYetImplemented,s,[GetObjName(El)],El); end; @@ -2173,15 +3330,27 @@ begin RaiseMsg(nIdentifierNotFound,sIdentifierNotFound,[Identifier],El); end; -function TPasResolver.CheckProcCompatibility(Proc: TPasProcedure; - Params: TParamsExpr; RaiseOnError: boolean): TProcCompatibility; +procedure TPasResolver.RaiseXExpectedButYFound(X, Y: string; El: TPasElement); +begin + RaiseMsg(nXExpectedButYFound,sXExpectedButYFound,[X,Y],El); +end; + +procedure TPasResolver.LogMsg(MsgType: TMessageType; MsgNumber: integer; + const Fmt: String; Args: array of const; PosEl: TPasElement); +begin + SetLastMsg(MsgType,MsgNumber,Fmt,Args,PosEl); + if Assigned(CurrentParser.OnLog) then + CurrentParser.OnLog(Self,Format(Fmt,Args)); +end; + +function TPasResolver.CheckCallProcCompatibility(Proc: TPasProcedure; + Params: TParamsExpr; RaiseOnError: boolean): integer; var ProcArgs: TFPList; - i, ParamCnt: Integer; + i, ParamCnt, ParamCompatibility: Integer; Param: TPasExpr; - ParamCompatibility: TProcCompatibility; begin - Result:=pcExact; + Result:=cExact; ProcArgs:=Proc.ProcType.Args; // check args ParamCnt:=length(Params.Params); @@ -2195,16 +3364,15 @@ begin if RaiseOnError then RaiseMsg(nWrongNumberOfParametersForCallTo, sWrongNumberOfParametersForCallTo,[GetProcDesc(Proc)],Param); - exit(pcIncompatible); + exit(cIncompatible); end; {$IFDEF VerbosePasResolver} - writeln('TPasResolver.CheckProcCompatibility ',i,'/',ParamCnt); + writeln('TPasResolver.CheckCallProcCompatibility ',i,'/',ParamCnt); {$ENDIF} ParamCompatibility:=CheckParamCompatibility(Param,TPasArgument(ProcArgs[i]),i+1,RaiseOnError); - if ParamCompatibility=pcIncompatible then - exit(pcIncompatible); - if ord(ParamCompatibility)ProcArgs2.Count then + exit; + for i:=0 to ProcArgs1.Count-1 do + begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.CheckOverloadProcCompatibility ',i,'/',ProcArgs1.Count); + {$ENDIF} + if not CheckProcArgCompatibility(Proc1,Proc2,i) then + exit; + end; + Result:=true; +end; + +function TPasResolver.CheckProcArgCompatibility(Proc1, Proc2: TPasProcedure; + ArgNo: integer): boolean; +var + Arg1, Arg2: TPasArgument; + ArgType1, ArgType2: TPasResolvedType; +begin + Result:=false; + Arg1:=TPasArgument(Proc1.ProcType.Args[ArgNo]); + Arg2:=TPasArgument(Proc2.ProcType.Args[ArgNo]); + + // check access: var, const, ... + if Arg1.Access<>Arg2.Access then exit; + + // check untyped + if Arg1.ArgType=nil then + exit(Arg2.ArgType=nil); + if Arg2.ArgType=nil then exit; + + GetResolvedType(Arg1.ArgType,true,ArgType1); + GetResolvedType(Arg2.ArgType,true,ArgType2); + + if (ArgType1.Kind<>ArgType2.Kind) + or (ArgType1.TypeEl=nil) + or (ArgType1.TypeEl<>ArgType2.TypeEl) then + exit; + + // ToDo: check Arg1.ValueExpr + Result:=true; +end; + function TPasResolver.CheckParamCompatibility(Expr: TPasExpr; - Param: TPasArgument; ParamNo: integer; RaiseOnError: boolean - ): TProcCompatibility; + Param: TPasArgument; ParamNo: integer; RaiseOnError: boolean): integer; var ExprType, ParamType: TPasResolvedType; @@ -2238,7 +3461,8 @@ var var MustFitExactly: Boolean; begin - Result:=pcIncompatible; + Result:=cIncompatible; + MustFitExactly:=Param.Access in [argVar, argOut]; GetResolvedType(Expr,not MustFitExactly,ExprType); @@ -2271,20 +3495,24 @@ begin if MustFitExactly then begin if (ParamType.Kind=ExprType.Kind) - or (ParamType.BaseType=ExprType.BaseType) then + //or (ParamType.BaseType=ExprType.BaseType) + then begin if (ParamType.TypeEl<>nil) and (ParamType.TypeEl=ExprType.TypeEl) then - exit(pcExact); + exit(cExact); end; if RaiseOnError then RaiseMsg(nIncompatibleTypeArgNoVarParamMustMatchExactly, sIncompatibleTypeArgNoVarParamMustMatchExactly, [ParamNo,GetTypeDesc(ExprType.TypeEl),GetTypeDesc(ParamType.TypeEl)], Expr); - exit(pcIncompatible); + exit(cIncompatible); end; // check if the Expr can be converted to Param + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.CheckParamCompatibility '); + {$ENDIF} case ParamType.Kind of rkIdentifier, rkExpr: @@ -2293,32 +3521,35 @@ begin if ParamType.TypeEl=nil then begin // ToDo: untyped parameter + RaiseNotYetImplemented(Param); end else if ParamType.BaseType=ExprType.BaseType then begin - // ToDo: check btFile, btText - exit(pcExact); // same base type, maybe not same type name (e.g. longint and integer) + if ParamType.BaseType=btContext then + exit(CheckCustomTypeCompatibility(ExprType,ParamType,Expr)) + else + exit(cExact); // same base type, maybe not same type name (e.g. longint and integer) end else if (ParamType.BaseType in btAllNumbers) and (ExprType.BaseType in btAllNumbers) then - exit(pcCompatible) // ToDo: range check for Expr + exit(cExact+1) // ToDo: range check for Expr else if (ParamType.BaseType in btAllBooleans) and (ExprType.BaseType in btAllBooleans) then - exit(pcCompatible) + exit(cExact+1) else if (ParamType.BaseType in btAllStrings) and (ExprType.BaseType in btAllStrings) then - exit(pcCompatible) // ToDo: check Expr if Param=btChar/btWideChar + exit(cExact+1) // ToDo: check Expr if Param=btChar/btWideChar else if (ParamType.BaseType in btAllFloats) and (ExprType.BaseType in btAllFloats) then - exit(pcCompatible) + exit(cExact+1) else if ExprType.BaseType=btNil then begin if ParamType.BaseType=btPointer then - exit(pcExact); + exit(cExact); // ToDo: allow classes and custom pointers end else - exit(pcIncompatible); + exit(cIncompatible); end; //rkArrayOf: ; //rkPointer: ; @@ -2328,18 +3559,45 @@ begin RaiseNotYetImplemented(Expr,':TPasResolver.CheckParamCompatibility: Param='+GetResolvedTypeDesc(ParamType)+' '+GetResolvedTypeDesc(ExprType)); end; +function TPasResolver.CheckCustomTypeCompatibility(const SrcType, + DestType: TPasResolvedType; ErrorEl: TPasElement): integer; +var + SrcTypeEl, DstTypeEl: TPasType; +begin + if (SrcType.TypeEl=nil) then + RaiseInternalError(''); + if (DestType.TypeEl=nil) then + RaiseInternalError(''); + SrcTypeEl:=SrcType.TypeEl; + DstTypeEl:=DestType.TypeEl; + + if SrcTypeEl.ClassType=TPasClassType then + begin + if DstTypeEl.ClassType=TPasClassType then + exit(CheckSrcIsADstType(SrcType,DestType,ErrorEl)) + else + RaiseNotYetImplemented(ErrorEl); + end + else + RaiseNotYetImplemented(ErrorEl); +end; + procedure TPasResolver.GetResolvedType(El: TPasElement; SkipTypeAlias: boolean; out ResolvedType: TPasResolvedType); var bt: TResolveBaseType; + DeclEl: TPasElement; begin ResolvedType:=Default(TPasResolvedType); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.GetResolvedType El=',GetObjName(El),' SkipTypeAlias=',SkipTypeAlias); + {$ENDIF} if El=nil then exit; if El.ClassType=TPrimitiveExpr then begin case TPrimitiveExpr(El).Kind of - pekIdent: + pekIdent,pekSelf: begin if El.CustomData is TResolvedReference then GetResolvedType(TResolvedReference(El.CustomData).Declaration,SkipTypeAlias,ResolvedType) @@ -2363,7 +3621,6 @@ begin //pekArrayParams: //pekListOfExp: //pekInherited: - //pekSelf: else RaiseNotYetImplemented(El,': cannot resolve this'); end; @@ -2379,11 +3636,28 @@ begin end; end else if El.ClassType=TPasAliasType then + begin // e.f. 'var a: b' -> resolve b - GetResolvedType(TPasTypeAliasType(El).DestType,true,ResolvedType) - else if (El.ClassType=TPasTypeAliasType) and SkipTypeAlias then + GetResolvedType(TPasTypeAliasType(El).DestType,true,ResolvedType); + ResolvedType.IdentEl:=El; + end + else if (El.ClassType=TPasTypeAliasType) then + begin // e.g. 'type a = type b;' -> resolve b - GetResolvedType(TPasTypeAliasType(El).DestType,true,ResolvedType) + if SkipTypeAlias then + begin + GetResolvedType(TPasTypeAliasType(El).DestType,true,ResolvedType); + if ResolvedType.BaseType=btContext then + begin + // a type alias of a custom type creates a new base type -> it can't be skipped + SetResolvedType(ResolvedType,rkIdentifier,btContext,El,TPasAliasType(El)); + end + else + ResolvedType.IdentEl:=El; + end + else + SetResolvedType(ResolvedType,rkIdentifier,btContext,El,TPasAliasType(El)); + end else if (El.ClassType=TPasVariable) or (El.ClassType=TPasConst) or (El.ClassType=TPasProperty) then begin @@ -2403,10 +3677,109 @@ begin ResolvedType.IdentEl:=El; end; end + else if El.ClassType=TPasClassType then + begin + if TPasClassType(El).IsForward then + begin + DeclEl:=(TPasClassType(El).CustomData as TResolvedReference).Declaration; + ResolvedType.TypeEl:=DeclEl as TPasClassType; + end + else + ResolvedType.TypeEl:=TPasClassType(El); + SetResolvedType(ResolvedType,rkIdentifier,btContext, + ResolvedType.TypeEl,ResolvedType.TypeEl); + end else RaiseNotYetImplemented(El,': cannot resolve this'); end; +function TPasResolver.GetPasClassAncestor(ClassEl: TPasClassType; + SkipAlias: boolean): TPasType; +var + DeclEl: TPasElement; + ClassScope: TPasClassScope; +begin + Result:=nil; + if ClassEl=nil then + exit; + if ClassEl.CustomData=nil then + exit; + if ClassEl.IsForward then + begin + DeclEl:=(ClassEl.CustomData as TResolvedReference).Declaration; + ClassEl:=DeclEl as TPasClassType; + Result:=ClassEl; + end + else + begin + ClassScope:=ClassEl.CustomData as TPasClassScope; + if not ClassScope.AncestorResolved then + exit; + if SkipAlias then + begin + if ClassScope.AncestorScope=nil then + exit; + Result:=TPasClassType(ClassScope.AncestorScope.Element); + end + else + Result:=ClassScope.DirectAncestor; + end; +end; + +function TPasResolver.CheckSrcIsADstType(const ResolvedSrcType, + ResolvedDestType: TPasResolvedType; ErrorEl: TPasElement): integer; +// finds distance between classes SrcType and DestType +var + SrcEl, DstEl: TPasElement; + ClassEl: TPasClassType; +begin + Result:=cIncompatible; + DstEl:=ResolvedDestType.TypeEl; + if DstEl=nil then exit(cIncompatible); + // skip Dst alias + while (DstEl<>nil) and (DstEl.ClassType=TPasAliasType) do + DstEl:=TPasAliasType(DstEl).DestType; + + SrcEl:=ResolvedSrcType.TypeEl; + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.CheckSrcIsADstType SrcEl=',GetObjName(SrcEl),' DstEl=',GetObjName(DstEl)); + {$ENDIF} + Result:=cExact; + while SrcEl<>nil do + begin + {$IFDEF VerbosePasResolver} + writeln(' Step=',Result,' SrcEl=',GetObjName(SrcEl),' DstEl=',GetObjName(DstEl)); + {$ENDIF} + if SrcEl=DstEl then exit; + if SrcEl.ClassType=TPasAliasType then + // alias -> skip + SrcEl:=TPasAliasType(SrcEl).DestType + else if SrcEl.ClassType=TPasTypeAliasType then + begin + // type alias -> increases distance + SrcEl:=TPasAliasType(SrcEl).DestType; + inc(Result); + end + else if SrcEl.ClassType=TPasClassType then + begin + ClassEl:=TPasClassType(SrcEl); + if ClassEl.IsForward then + // class forward -> skip + SrcEl:=(ClassEl.CustomData as TResolvedReference).Declaration + else + begin + // class ancestor -> increase distance + SrcEl:=(ClassEl.CustomData as TPasClassScope).DirectAncestor; + inc(Result); + end; + end + else + exit(cIncompatible); + end; + if ErrorEl=nil then ; + Result:=cIncompatible; +end; + { TPasIdentifierScope } procedure TPasIdentifierScope.OnClearItem(Item, Dummy: pointer); @@ -2479,6 +3852,43 @@ begin Result:=TPasIdentifier(FItems.Find(LoName)); end; +function TPasIdentifierScope.RemoveIdentifier(El: TPasElement): boolean; +var + LoName: ShortString; + Identifier, LastIdentifier: TPasIdentifier; +begin + LoName:=lowercase(El.Name); + Identifier:=TPasIdentifier(FItems.Find(LoName)); + LastIdentifier:=nil; + Result:=false; + while Identifier<>nil do + begin + if Identifier.Element=El then + begin + if LastIdentifier<>nil then + begin + LastIdentifier.NextSameIdentifier:=Identifier.NextSameIdentifier; + Identifier.Free; + Identifier:=LastIdentifier.NextSameIdentifier; + end + else + begin + FItems.Remove(Identifier); + LastIdentifier:=Identifier; + Identifier:=Identifier.NextSameIdentifier; + LastIdentifier.Free; + LastIdentifier:=nil; + if Identifier<>nil then + FItems.Add(LoName,Identifier); + end; + Result:=true; + continue; + end; + LastIdentifier:=Identifier; + Identifier:=Identifier.NextSameIdentifier; + end; +end; + function TPasIdentifierScope.AddIdentifier(const Identifier: String; El: TPasElement; const Kind: TPasIdentifierKind): TPasIdentifier; var diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index d66adad9ec..b4103ab66c 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -581,7 +581,7 @@ type public PackMode: TPackMode; ObjKind: TPasObjKind; - AncestorType: TPasType; // TPasClassType or TPasUnresolvedTypeRef + AncestorType: TPasType; // TPasClassType or TPasUnresolvedTypeRef or TPasAliasType or TPasTypeAliasType HelperForType: TPasType; // TPasClassType or TPasUnresolvedTypeRef IsForward: Boolean; IsShortDefinition: Boolean;//class(anchestor); without end @@ -752,10 +752,14 @@ type procedure ForEachCall(const aMethodCall: TListCallback; const Arg: Pointer); override; public - IndexExpr, - DefaultExpr : TPasExpr; + IndexExpr: TPasExpr; + ReadAccessor: TPasExpr; + WriteAccessor: TPasExpr; + ImplementsFunc: TPasExpr; + StoredAccessor: TPasExpr; // can be nil, if StoredAccessorName is 'True' or 'False' + DefaultExpr: TPasExpr; Args: TFPList; // List of TPasArgument objects - ReadAccessorName, WriteAccessorName,ImplementsName, + ReadAccessorName, WriteAccessorName, ImplementsName, StoredAccessorName: string; IsClass, IsDefault, IsNodefault: Boolean; Function ResolvedType : TPasType; @@ -2415,9 +2419,13 @@ var begin for i := 0 to Args.Count - 1 do TPasArgument(Args[i]).Release; - Args.Free; - ReleaseAndNil(TPasElement(DefaultExpr)); + FreeAndNil(Args); ReleaseAndNil(TPasElement(IndexExpr)); + ReleaseAndNil(TPasElement(ReadAccessor)); + ReleaseAndNil(TPasElement(WriteAccessor)); + ReleaseAndNil(TPasElement(ImplementsFunc)); + ReleaseAndNil(TPasElement(StoredAccessor)); + ReleaseAndNil(TPasElement(DefaultExpr)); inherited Destroy; end; @@ -3386,6 +3394,14 @@ begin IndexExpr.ForEachCall(aMethodCall,Arg); for i:=0 to Args.Count-1 do TPasElement(Args[i]).ForEachCall(aMethodCall,Arg); + if ReadAccessor<>nil then + ReadAccessor.ForEachCall(aMethodCall,Arg); + if WriteAccessor<>nil then + WriteAccessor.ForEachCall(aMethodCall,Arg); + if ImplementsFunc<>nil then + ImplementsFunc.ForEachCall(aMethodCall,Arg); + if StoredAccessor<>nil then + StoredAccessor.ForEachCall(aMethodCall,Arg); if DefaultExpr<>nil then DefaultExpr.ForEachCall(aMethodCall,Arg); end; @@ -3880,6 +3896,7 @@ end; procedure TPasImplCaseStatement.AddExpression(const Expr: TPasExpr); begin Expressions.Add(Expr); + Expr.Parent:=Self; end; procedure TPasImplCaseStatement.ForEachCall( diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index aa85a2ed57..af63668221 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -136,10 +136,10 @@ type stProcedure, // also method, procedure, constructor, destructor, ... stProcedureHeader, stExceptOnExpr, - stExceptOnStatement - //stDeclaration, // e.g. the A in 'type A=B;' + stExceptOnStatement, + stDeclaration, // e.g. a TPasType, TPasProperty //stStatement, - //stAncestors // the list of ancestors and interfaces of a class + stAncestors // the list of ancestors and interfaces of a class ); TPasScopeTypes = set of TPasScopeType; @@ -278,6 +278,8 @@ type function CreateBinaryExpr(AParent : TPasElement; xleft, xright: TPasExpr; AOpCode: TExprOpCode): TBinaryExpr; procedure AddToBinaryExprChain(var ChainFirst, ChainLast: TPasExpr; Element: TPasExpr; AOpCode: TExprOpCode); + procedure AddParamsToBinaryExprChain(var ChainFirst, ChainLast: TPasExpr; + Params: TParamsExpr); function CreateUnaryExpr(AParent : TPasElement; AOperand: TPasExpr; AOpCode: TExprOpCode): TUnaryExpr; function CreateArrayValues(AParent : TPasElement): TArrayValues; function CreateFunctionType(const AName, AResultName: String; AParent: TPasElement; @@ -334,7 +336,7 @@ type function ParseEnumType(Parent: TPasElement; Const NamePos: TPasSourcePos; const TypeName: String): TPasEnumType; function ParseSetType(Parent: TPasElement; Const NamePos: TPasSourcePos; const TypeName: String ): TPasSetType; function ParseSpecializeType(Parent: TPasElement; Const TypeName: String): TPasClassType; - Function ParseClassDecl(Parent: TPasElement; Const AClassName: String; AObjKind: TPasObjKind; PackMode : TPackMode= pmNone): TPasType; + Function ParseClassDecl(Parent: TPasElement; Const NamePos: TPasSourcePos; Const AClassName: String; AObjKind: TPasObjKind; PackMode : TPackMode= pmNone): TPasType; Function ParseProperty(Parent : TPasElement; Const AName : String; AVisibility : TPasMemberVisibility) : TPasProperty; function ParseRangeType(AParent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String; Full: Boolean = True): TPasRangeType; procedure ParseExportDecl(Parent: TPasElement; List: TFPList); @@ -1047,16 +1049,19 @@ begin K:=stkAlias else if (CurToken=tkSquaredBraceOpen) then begin + // Todo: check via resolver if ((LowerCase(Name)='string') or (LowerCase(Name)='ansistring')) then // Type A = String[12]; K:=stkString else ParseExcSyntaxError; end - else // Type A = A..B; - K:=stkRange; + else if CurToken=tkDotDot then // Type A = A..B; + K:=stkRange + else + ParseExcTokenError(';'); UnGetToken; end - else if (CurToken=tkDotDot) then // Type A = B; + else if (CurToken=tkDotDot) then // A: B..C; begin K:=stkRange; UnGetToken; @@ -1205,6 +1210,7 @@ var CH , ok: Boolean; // Check hint ? begin Result := nil; + // NextToken and check pack mode Pm:=CheckPackMode; if Full then CH:=Not (CurToken in NoHintTokens) @@ -1218,10 +1224,10 @@ begin Try case CurToken of // types only allowed when full - tkObject: Result := ParseClassDecl(Parent, TypeName, okObject,PM); - tkInterface: Result := ParseClassDecl(Parent, TypeName, okInterface); + tkObject: Result := ParseClassDecl(Parent, NamePos, TypeName, okObject,PM); + tkInterface: Result := ParseClassDecl(Parent, NamePos, TypeName, okInterface); tkSpecialize: Result:=ParseSpecializeType(Parent,TypeName); - tkClass: Result := ParseClassDecl(Parent, TypeName, okClass, PM); + tkClass: Result := ParseClassDecl(Parent, NamePos, TypeName, okClass, PM); tkType: Result:=ParseAliasType(Parent,NamePos,TypeName); // Always allowed tkIdentifier: Result:=ParseSimpleType(Parent,NamePos,TypeName,Full); @@ -1238,7 +1244,7 @@ begin if (Curtoken=tkHelper) then begin UnGetToken; - Result:=ParseClassDecl(Parent,TypeName,okRecordHelper,PM); + Result:=ParseClassDecl(Parent,NamePos,TypeName,okRecordHelper,PM); end else begin @@ -1246,9 +1252,13 @@ begin Result := ParseRecordDecl(Parent,NamePos,TypeName,PM); end; end; + tkNumber,tkMinus: + begin + UngetToken; + Result:=ParseRangeType(Parent,NamePos,TypeName,Full); + end; else - UngetToken; - Result:=ParseRangeType(Parent,NamePos,TypeName,Full); + ParseExcExpectedIdentifier; end; if CH then CheckHint(Result,True); @@ -1373,7 +1383,7 @@ begin NextToken; if not isEndOfExp then begin repeat - p:=DoParseExpression(AParent); + p:=DoParseExpression(params); if not Assigned(p) then Exit; // bad param syntax params.AddParam(p); @@ -1531,23 +1541,16 @@ begin ParseExcExpectedIdentifier; end; end; - while CurToken in [tkBraceOpen, tkSquaredBraceOpen, tkCaret] do + repeat case CurToken of - tkBraceOpen: + tkBraceOpen,tkSquaredBraceOpen: begin - prm:=ParseParams(AParent,pekFuncParams); + if CurToken=tkBraceOpen then + prm:=ParseParams(AParent,pekFuncParams) + else + prm:=ParseParams(AParent,pekArrayParams); if not Assigned(prm) then Exit; - prm.Value:=Last; - Result:=prm; - Last:=prm; - end; - tkSquaredBraceOpen: - begin - prm:=ParseParams(AParent,pekArrayParams); - if not Assigned(prm) then Exit; - prm.Value:=Last; - Result:=prm; - Last:=prm; + AddParamsToBinaryExprChain(Result,Last,prm); end; tkCaret: begin @@ -1555,7 +1558,10 @@ begin Last:=Result; NextToken; end; - end; + else + break; + end; + until false; // Needed for TSDOBaseDataObjectClass(Self.ClassType).Create if CurToken in [tkdot,tkas] then begin @@ -1725,9 +1731,9 @@ begin begin tempop:=PopOper; x:=popexp; - if (tempop=tkMinus) and (X.Kind=pekRange) then + if (tempop=tkMinus) and (x.Kind=pekRange) then begin - TBinaryExpr(x).Left:=CreateUnaryExpr(x, TBinaryExpr(X).left, eopSubtract); + TBinaryExpr(x).Left:=CreateUnaryExpr(x, TBinaryExpr(x).left, eopSubtract); expstack.Add(x); end else @@ -1751,7 +1757,7 @@ begin PushOper(CurToken); NextToken; end; - // Writeln('Bin ',NotBinary ,' or EOE ',isEndOfExp, ' Ex ',Assigned(x),' stack ',ExpStack.Count); + // Writeln('Bin ',NotBinary ,' or EOE ',isEndOfExp, ' Ex ',Assigned(x),' stack ',ExpStack.Count); until NotBinary or isEndOfExp; if not NotBinary then ParseExcExpectedIdentifier; @@ -1759,7 +1765,11 @@ begin while opstackTop>=0 do PopAndPushOperator; // only 1 expression should be on the stack, at the end of the correct expression - if expstack.Count=1 then Result:=TPasExpr(expstack[0]); + if expstack.Count=1 then + begin + Result:=TPasExpr(expstack[0]); + Result.Parent:=AParent; + end; finally {if Not Assigned(Result) then @@ -1792,26 +1802,26 @@ var r : TRecordValues; a : TArrayValues; -function lastfield:boolean; + function lastfield:boolean; -begin - result:= CurToken<>tkSemicolon; - if not result then - begin - nexttoken; - if curtoken=tkbraceclose then - result:=true - else - ungettoken; - end; -end; + begin + result:= CurToken<>tkSemicolon; + if not result then + begin + nexttoken; + if curtoken=tkbraceclose then + result:=true + else + ungettoken; + end; + end; begin if CurToken <> tkBraceOpen then Result:=DoParseExpression(AParent) else begin NextToken; - x:=DoParseConstValueExpression(Aparent); + x:=DoParseConstValueExpression(AParent); case CurToken of tkComma: // array of values (a,b,c); begin @@ -1900,7 +1910,10 @@ var begin With Decs do begin - OverloadedProc:=CheckOverloadList(Functions,AProc.Name,OldMember); + if not (po_nooverloadedprocs in Options) then + OverloadedProc:=CheckOverloadList(Functions,AProc.Name,OldMember) + else + OverloadedProc:=nil; If (OverloadedProc<>Nil) then begin OverLoadedProc.Overloads.Add(AProc); @@ -1929,7 +1942,7 @@ var begin Result:=AParent; - If AParent is TPasClassType then + If (not (po_nooverloadedprocs in Options)) and (AParent is TPasClassType) then begin OverloadedProc:=CheckOverLoadList(TPasClassType(AParent).Members,AName,Member); If (OverloadedProc<>Nil) then @@ -2244,6 +2257,7 @@ begin begin If LogEvent(pleImplementation) then DoLog(mtInfo,nLogStartImplementation,SLogStartImplementation); + SetBlock(declNone); ParseImplementation; end; break; @@ -2252,6 +2266,7 @@ begin if (Declarations is TInterfaceSection) or ((Declarations is TImplementationSection) and not (Declarations is TProgramSection)) then begin + SetBlock(declNone); ParseInitialization; break; end; @@ -2259,6 +2274,7 @@ begin if (Declarations is TInterfaceSection) or ((Declarations is TImplementationSection) and not (Declarations is TProgramSection)) then begin + SetBlock(declNone); ParseFinalization; break; end; @@ -2447,12 +2463,14 @@ begin begin if Declarations is TProcedureBody then begin + SetBlock(declNone); ParseProcBeginBlock(TProcedureBody(Declarations)); break; end else if (Declarations is TInterfaceSection) or (Declarations is TImplementationSection) then begin + SetBlock(declNone); ParseInitialization; break; end @@ -2461,6 +2479,7 @@ begin end; tklabel: begin + SetBlock(declNone); if not (Declarations is TInterfaceSection) then ParseLabels(Declarations); end; @@ -2468,6 +2487,7 @@ begin ParseExcSyntaxError; end; end; + SetBlock(declNone); end; function TPasParser.CheckUseUnit(ASection: TPasSection; AUnitName: string @@ -3008,6 +3028,7 @@ begin else ParseExc(nParserExpectedConstVarID,SParserExpectedConstVarID); Arg := TPasArgument(CreateElement(TPasArgument, Name, Parent)); + Arg.Access := Access; Args.Add(Arg); NextToken; if CurToken = tkColon then @@ -3026,7 +3047,8 @@ begin Value:=Nil; if not IsUntyped then begin - ArgType := ParseType(Parent,Scanner.CurSourcePos); + Arg := TPasArgument(Args[0]); + ArgType := ParseType(Arg,Scanner.CurSourcePos); ok:=false; try NextToken; @@ -3049,7 +3071,7 @@ begin UngetToken; ok:=true; finally - if not ok then + if (not ok) and (ArgType<>nil) then ArgType.Release; end; end; @@ -3057,11 +3079,9 @@ begin for i := OldArgCount to Args.Count - 1 do begin Arg := TPasArgument(Args[i]); - Arg.Access := Access; Arg.ArgType := ArgType; if Assigned(ArgType) then begin - ArgType.Parent := Arg; if (i > OldArgCount) then ArgType.AddRef; end; @@ -3105,7 +3125,7 @@ begin end; end; -procedure TPasParser.HandleProcedureModifier(Parent: TPasElement;pm : TProcedureModifier); +procedure TPasParser.HandleProcedureModifier(Parent: TPasElement; pm: TProcedureModifier); Var Tok : String; @@ -3240,7 +3260,7 @@ Var begin // Element must be non-nil. Removed all checks for not-nil. // If it is nil, the following fails anyway. - CheckProcedureArgs(Parent,Element.Args,ProcType in [ptOperator,ptClassOperator]); + CheckProcedureArgs(Element,Element.Args,ProcType in [ptOperator,ptClassOperator]); case ProcType of ptFunction,ptClassFunction: begin @@ -3377,35 +3397,46 @@ end; function TPasParser.ParseProperty(Parent: TPasElement; const AName: String; AVisibility: TPasMemberVisibility): TPasProperty; - procedure MaybeReadFullyQualifiedIdentifier(Var r : String); - - begin - while True do - begin - NextToken; - if CurToken = tkDot then - begin - ExpectIdentifier; - R:=R + '.' + CurTokenString; - end - else - break; - end; - end; - - function GetAccessorName: String; + function GetAccessorName(aParent: TPasElement; out Expr: TPasExpr): String; + var + Last: TPasExpr; + Params: TParamsExpr; + Param: TPasExpr; begin ExpectIdentifier; Result := CurTokenString; - MaybeReadFullyQualifiedIdentifier(Result); + Expr := CreatePrimitiveExpr(aParent,pekIdent,CurTokenString); + Last := Expr; + + // read .subident.subident... + repeat + NextToken; + if CurToken <> tkDot then break; + ExpectIdentifier; + Result := Result + '.' + CurTokenString; + AddToBinaryExprChain(Expr,Last,CreatePrimitiveExpr(aParent,pekIdent,CurTokenString),eopSubIdent); + until false; + + // read optional array index if CurToken <> tkSquaredBraceOpen then UnGetToken else begin Result := Result + '['; + Params:=TParamsExpr(CreateElement(TParamsExpr,'',aParent)); + Params.Kind:=pekArrayParams; + AddParamsToBinaryExprChain(Expr,Last,Params); NextToken; - if CurToken in [tkIdentifier, tkNumber] then - Result := Result + CurTokenString; + case CurToken of + tkChar: Param:=CreatePrimitiveExpr(aParent,pekString, CurTokenText); + tkNumber: Param:=CreatePrimitiveExpr(aParent,pekNumber, CurTokenString); + tkIdentifier: Param:=CreatePrimitiveExpr(aParent,pekIdent, CurTokenText); + tkfalse, tktrue: Param:=CreateBoolConstExpr(aParent,pekBoolConst, CurToken=tktrue); + else + ParseExcExpectedIdentifier; + end; + Params.AddParam(Param); + Result := Result + CurTokenString; ExpectToken(tkSquaredBraceClose); Result := Result + ']'; end; @@ -3438,17 +3469,17 @@ begin end; if CurTokenIsIdentifier('READ') then begin - Result.ReadAccessorName := GetAccessorName; + Result.ReadAccessorName := GetAccessorName(Result,Result.ReadAccessor); NextToken; end; if CurTokenIsIdentifier('WRITE') then begin - Result.WriteAccessorName := GetAccessorName; + Result.WriteAccessorName := GetAccessorName(Result,Result.WriteAccessor); NextToken; end; if CurTokenIsIdentifier('IMPLEMENTS') then begin - Result.ImplementsName := GetAccessorName; + Result.ImplementsName := GetAccessorName(Result,Result.ImplementsFunc); NextToken; end; if CurTokenIsIdentifier('STORED') then @@ -3459,7 +3490,10 @@ begin else if CurToken = tkFalse then Result.StoredAccessorName := 'False' else if CurToken = tkIdentifier then - Result.StoredAccessorName := CurTokenString + begin + UngetToken; + Result.StoredAccessorName := GetAccessorName(Result,Result.StoredAccessor); + end else ParseExcSyntaxError; NextToken; @@ -3505,6 +3539,7 @@ begin if not ok then Result.Release; end; + Engine.FinishScope(stDeclaration,Result); end; // Starts after the "begin" token @@ -3809,6 +3844,7 @@ begin ExpectToken(tkof); El:=TPasImplCaseOf(CreateElement(TPasImplCaseOf,'',CurBlock)); TPasImplCaseOf(El).CaseExpr:=Left; + Left.Parent:=El; CreateBlock(TPasImplCaseOf(El)); repeat NextToken; @@ -3840,7 +3876,7 @@ begin end else repeat - Left:=DoParseExpression(Parent); + Left:=DoParseExpression(CurBlock); //writeln(i,'CASE value="',Expr,'" Token=',CurTokenText); if CurBlock is TPasImplCaseStatement then TPasImplCaseStatement(CurBlock).Expressions.Add(Left) @@ -4401,7 +4437,7 @@ var Proc: TPasProcedure; ProcType: TProcType; begin - ProcType:=GetProcTypeFromtoken(CurToken,isClass); + ProcType:=GetProcTypeFromToken(CurToken,isClass); Proc:=ParseProcedureOrFunctionDecl(AType,ProcType,AVisibility); if Proc.Parent is TPasOverloadedProc then TPasOverloadedProc(Proc.Parent).Overloads.Add(Proc) @@ -4584,6 +4620,7 @@ begin AType.HelperForType:=ParseType(AType,Scanner.CurSourcePos); NextToken; end; + Engine.FinishScope(stAncestors,AType); if (AType.IsShortDefinition or AType.IsForward) then UngetToken else @@ -4601,23 +4638,19 @@ begin end; function TPasParser.ParseClassDecl(Parent: TPasElement; - const AClassName: String; AObjKind: TPasObjKind; PackMode: TPackMode - ): TPasType; + const NamePos: TPasSourcePos; const AClassName: String; + AObjKind: TPasObjKind; PackMode: TPackMode): TPasType; Var - SrcPos: TPasSourcePos; ok: Boolean; begin - // Save current parsing position to get it correct in all cases - SrcPos := Scanner.CurSourcePos; - NextToken; if (AObjKind = okClass) and (CurToken = tkOf) then begin Result := TPasClassOfType(CreateElement(TPasClassOfType, AClassName, - Parent, SrcPos)); + Parent, NamePos)); ExpectIdentifier; UngetToken; // Only names are allowed as following type TPasClassOfType(Result).DestType := ParseType(Result,Scanner.CurSourcePos); @@ -4632,13 +4665,14 @@ begin NextToken; end; Result := TPasClassType(CreateElement(TPasClassType, AClassName, - Parent, SrcPos)); + Parent, NamePos)); ok:=false; try TPasClassType(Result).ObjKind := AObjKind; TPasClassType(Result).PackMode:=PackMode; DoParseClassType(TPasClassType(Result)); + Engine.FinishScope(stTypeDef,Result); ok:=true; finally if not ok then @@ -4747,12 +4781,47 @@ begin end; end; +procedure TPasParser.AddParamsToBinaryExprChain(var ChainFirst, + ChainLast: TPasExpr; Params: TParamsExpr); +// append Params to chain, using the last element as Params.Value +var + Bin: TBinaryExpr; +begin + if Params.Value<>nil then + ParseExcSyntaxError; + if ChainLast=nil then + ParseExcSyntaxError; + if ChainLast is TBinaryExpr then + begin + Bin:=TBinaryExpr(ChainLast); + if Bin.left=nil then + ParseExcSyntaxError; + if Bin.right=nil then + ParseExcSyntaxError; + Params.Value:=Bin.right; + Params.Value.Parent:=Params; + Bin.right:=Params; + Params.Parent:=Bin; + end + else + begin + if ChainFirst<>ChainLast then + ParseExcSyntaxError; + Params.Value:=ChainFirst; + Params.Parent:=ChainFirst.Parent; + ChainFirst.Parent:=Params; + ChainFirst:=Params; + ChainLast:=Params; + end; +end; + function TPasParser.CreateUnaryExpr(AParent: TPasElement; AOperand: TPasExpr; AOpCode: TExprOpCode): TUnaryExpr; begin Result:=TUnaryExpr(CreateElement(TUnaryExpr,'',AParent)); Result.Kind:=pekUnary; Result.Operand:=AOperand; + Result.Operand.Parent:=Result; Result.OpCode:=AOpCode; end; diff --git a/packages/fcl-passrc/src/pscanner.pp b/packages/fcl-passrc/src/pscanner.pp index c831f1dc71..fd0a82388d 100644 --- a/packages/fcl-passrc/src/pscanner.pp +++ b/packages/fcl-passrc/src/pscanner.pp @@ -329,7 +329,8 @@ type po_delphi, // Delphi mode: forbid nested comments po_cassignments, // allow C-operators += -= *= /= po_resolvestandardtypes, // search for 'longint', 'string', etc., do not use dummies, TPasResolver sets this to use its declarations - po_asmwhole // store whole text between asm..end in TPasImplAsmStatement.Tokens + po_asmwhole, // store whole text between asm..end in TPasImplAsmStatement.Tokens + po_nooverloadedprocs // do not create TPasOverloadedProc for procs with same name ); TPOptions = set of TPOption; diff --git a/packages/fcl-passrc/tests/tcexprparser.pas b/packages/fcl-passrc/tests/tcexprparser.pas index 2b55a7bf22..065e6e5c32 100644 --- a/packages/fcl-passrc/tests/tcexprparser.pas +++ b/packages/fcl-passrc/tests/tcexprparser.pas @@ -210,13 +210,14 @@ Var begin DeclareVar('record a : array[1..2] of integer; end ','b'); ParseExpression('b.a[1]'); - P:=TParamsExpr(AssertExpression('Simple identifier',theExpr,pekArrayParams,TParamsExpr)); - B:=AssertExpression('Name of array',P.Value,pekBinary,TBInaryExpr) as TBinaryExpr; - AssertEquals('name is Subident',eopSubIdent,B.Opcode); + B:=AssertExpression('Binary of record',TheExpr,pekBinary,TBinaryExpr) as TBinaryExpr; + AssertEquals('Name is Subident',eopSubIdent,B.Opcode); AssertExpression('Name of array',B.Left,pekIdent,'b'); - AssertExpression('Name of array',B.Right,pekIdent,'a'); - AssertEquals('One dimension',1,Length(p.params)); - AssertExpression('Simple identifier',p.params[0],pekNumber,'1'); + P:=TParamsExpr(AssertExpression('Simple identifier',B.right,pekArrayParams,TParamsExpr)); + AssertExpression('Name of array',P.Value,pekIdent,'a'); + TAssert.AssertSame('P.value.parent=P',P,P.Value.Parent); + AssertEquals('One dimension',1,Length(P.params)); + AssertExpression('Simple identifier',P.params[0],pekNumber,'1'); TAssert.AssertSame('B.left.parent=B',B,B.left.Parent); TAssert.AssertSame('B.right.parent=B',B,B.right.Parent); end; diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 8f1fcca691..5751995ba9 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -58,6 +58,11 @@ Type end; PTestResolverReferenceData = ^TTestResolverReferenceData; + TSystemUnitPart = ( + supTObject + ); + TSystemUnitParts = set of TSystemUnitPart; + { TTestResolver } TTestResolver = Class(TTestParser) @@ -69,6 +74,7 @@ Type function GetModules(Index: integer): TTestEnginePasResolver; function OnPasResolverFindUnit(const aUnitName: String): TPasModule; procedure OnFindReference(Element, FindData: pointer); + procedure OnCheckElementParent(data, arg: pointer); Protected Procedure SetUp; override; Procedure TearDown; override; @@ -82,38 +88,98 @@ Type function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver; function AddModuleWithIntfImplSrc(aFilename, InterfaceSrc, ImplementationSrc: string): TTestEnginePasResolver; - procedure AddSystemUnit; - procedure StartProgram(NeedSystemUnit: boolean); + procedure AddSystemUnit(Parts: TSystemUnitParts = []); + procedure StartProgram(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); procedure StartUnit(NeedSystemUnit: boolean); property Modules[Index: integer]: TTestEnginePasResolver read GetModules; property ModuleCount: integer read GetModuleCount; + property ResolverEngine: TTestEnginePasResolver read FResolverEngine; Published Procedure TestEmpty; + // alias Procedure TestAliasType; Procedure TestAlias2Type; Procedure TestAliasTypeRefs; + // var, const Procedure TestVarLongint; Procedure TestVarInteger; Procedure TestConstInteger; + Procedure TestDuplicateVar; + // operators Procedure TestPrgAssignment; Procedure TestPrgProcVar; Procedure TestUnitProcVar; + // statements Procedure TestForLoop; Procedure TestStatements; Procedure TestCaseStatement; Procedure TestTryStatement; Procedure TestStatementsRefs; + // units Procedure TestUnitRef; + // procs Procedure TestProcParam; Procedure TestFunctionResult; Procedure TestProcOverload; - Procedure TestProcOverloadRefs; + Procedure TestProcOverloadWithBaseTypes; + Procedure TestProcOverloadWithClassTypes; + Procedure TestProcOverloadWithInhClassTypes; + Procedure TestProcOverloadWithInhAliasClassTypes; + Procedure TestProcDuplicate; Procedure TestNestedProc; - Procedure TestDuplicateVar; + Procedure TestForwardProc; + Procedure TestForwardProcUnresolved; + Procedure TestNestedForwardProc; + Procedure TestNestedForwardProcUnresolved; + Procedure TestForwardProcFuncMismatch; + Procedure TestForwardFuncResultMismatch; + Procedure TestUnitIntfProc; + Procedure TestUnitIntfProcUnresolved; + Procedure TestUnitIntfMismatchArgName; + Procedure TestProcOverloadIsNotFunc; + // record Procedure TestRecord; Procedure TestRecordVariant; Procedure TestRecordVariantNested; - property ResolverEngine: TTestEnginePasResolver read FResolverEngine; + // class + Procedure TestClass; + Procedure TestClassDefaultInheritance; + Procedure TestClassTripleInheritance; + Procedure TestClassForward; + Procedure TestClassForwardNotResolved; + Procedure TestClassMethod; + Procedure TestClassMethodUnresolved; + Procedure TestClassMethodAbstract; + Procedure TestClassMethodAbstractWithoutVirtual; + Procedure TestClassMethodAbstractHasBody; + Procedure TestClassMethodUnresolvedWithAncestor; + Procedure TestClassProcFuncMismatch; + Procedure TestClassMethodOverload; + Procedure TestClassMethodInvalidOverload; + Procedure TestClassOverride; + Procedure TestClassMethodScope; + Procedure TestClassIdentifierSelf; + Procedure TestClassCallInherited; + // property + Procedure TestProperty1; + Procedure TestPropertyAccessorNotInFront; + Procedure TestPropertyReadAccessorVarWrongType; + Procedure TestPropertyReadAccessorProcNotFunc; + Procedure TestPropertyReadAccessorFuncWrongResult; + Procedure TestPropertyReadAccessorFuncWrongArgCount; + Procedure TestPropertyReadAccessorFunc; + Procedure TestPropertyWriteAccessorVarWrongType; + Procedure TestPropertyWriteAccessorFuncNotProc; + Procedure TestPropertyWriteAccessorProcWrongArgCount; + Procedure TestPropertyWriteAccessorProcWrongArg; + Procedure TestPropertyWriteAccessorProcWrongArgType; + Procedure TestPropertyWriteAccessorProc; + Procedure TestPropertyTypeless; + Procedure TestPropertyTypelessNoAncestor; + Procedure TestPropertyStoredAccessorProcNotFunc; + Procedure TestPropertyStoredAccessorFuncWrongResult; + Procedure TestPropertyStoredAccessorFuncWrongArgCount; + Procedure TestPropertyArgs1; end; function LinesToStr(Args: array of const): string; @@ -446,7 +512,7 @@ var begin p:=CommentStartP+2; Identifier:=ReadIdentifier(p); - //writeln('TTestResolver.CheckReferenceDirectives.AddPointer ',Identifier); + //writeln('TTestResolver.CheckReferenceDirectives.AddDirectReference ',Identifier); AddMarkerForTokenBehindComment(mkDirectReference,Identifier); end; @@ -551,7 +617,7 @@ var El, LabelEl: TPasElement; Ref: TResolvedReference; begin - //writeln('CheckReference searching reference: ',aMarker^.Filename,' Line=',aMarker^.LineNumber,' Col=',aMarker^.StartCol,'-',aMarker^.EndCol,' Label="',aMarker^.Identifier,'"'); + //writeln('CheckResolverReference searching reference: ',aMarker^.Filename,' Line=',aMarker^.LineNumber,' Col=',aMarker^.StartCol,'-',aMarker^.EndCol,' Label="',aMarker^.Identifier,'"'); aLabel:=FindLabel(aMarker^.Identifier); if aLabel=nil then RaiseErrorAt('label "'+aMarker^.Identifier+'" not found',aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol); @@ -593,7 +659,7 @@ var Ref:=TResolvedReference(El.CustomData); write(' Decl=',GetObjName(Ref.Declaration)); ResolverEngine.UnmangleSourceLineNumber(Ref.Declaration.SourceLinenumber,aLine,aCol); - write(Ref.Declaration.SourceFilename,'(',aLine,',',aCol,')'); + write(',',Ref.Declaration.SourceFilename,'(',aLine,',',aCol,')'); end else write(' has no TResolvedReference'); @@ -618,18 +684,23 @@ var // check if one element at {=a} is a TPasAliasType pointing to an element labeled {#a} var aLabel: PMarker; - ReferenceElements: TFPList; - i, LabelLine, LabelCol: Integer; - El: TPasElement; - DeclEl: TPasType; + ReferenceElements, LabelElements: TFPList; + i, LabelLine, LabelCol, j: Integer; + El, LabelEl: TPasElement; + DeclEl, TypeEl: TPasType; begin - //writeln('CheckPointer searching pointer: ',aMarker^.Filename,' Line=',aMarker^.LineNumber,' Col=',aMarker^.StartCol,'-',aMarker^.EndCol,' Label="',aMarker^.Identifier,'"'); + writeln('CheckDirectReference searching pointer: ',aMarker^.Filename,' Line=',aMarker^.LineNumber,' Col=',aMarker^.StartCol,'-',aMarker^.EndCol,' Label="',aMarker^.Identifier,'"'); aLabel:=FindLabel(aMarker^.Identifier); if aLabel=nil then - RaiseErrorAt('label "'+aMarker^.Identifier+'" not found',aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol); + RaiseErrorAt('label "'+aMarker^.Identifier+'" not found',aMarker); + LabelElements:=nil; ReferenceElements:=nil; try + LabelElements:=FindElementsAt(aLabel^.Filename,aLabel^.LineNumber,aLabel^.StartCol,aLabel^.EndCol); + if LabelElements.Count=0 then + RaiseErrorAt('label "'+aLabel^.Identifier+'" has no elements',aLabel); + ReferenceElements:=FindElementsAt(aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol,aMarker^.EndCol); if ReferenceElements.Count=0 then RaiseErrorAt('reference "'+aMarker^.Identifier+'" has no elements',aMarker); @@ -637,7 +708,19 @@ var for i:=0 to ReferenceElements.Count-1 do begin El:=TPasElement(ReferenceElements[i]); - if El.ClassType=TPasAliasType then + //writeln('CheckDirectReference ',i,'/',ReferenceElements.Count,' ',GetTreeDesc(El,2)); + if El.ClassType=TPasVariable then + begin + AssertNotNull('TPasVariable(El='+El.Name+').VarType',TPasVariable(El).VarType); + TypeEl:=TPasVariable(El).VarType; + for j:=0 to LabelElements.Count-1 do + begin + LabelEl:=TPasElement(LabelElements[j]); + if TypeEl=LabelEl then + exit; // success + end; + end + else if El is TPasAliasType then begin DeclEl:=TPasAliasType(El).DestType; ResolverEngine.UnmangleSourceLineNumber(DeclEl.SourceLinenumber,LabelLine,LabelCol); @@ -646,13 +729,36 @@ var and (aLabel^.StartCol<=LabelCol) and (aLabel^.EndCol>=LabelCol) then exit; // success - writeln('CheckDirectReference Decl at ',DeclEl.SourceFilename,'(',LabelLine,',',LabelCol,')'); - RaiseErrorAt('wrong direct reference "'+aMarker^.Identifier+'"',aMarker); + end + else if El.ClassType=TPasArgument then + begin + TypeEl:=TPasArgument(El).ArgType; + for j:=0 to LabelElements.Count-1 do + begin + LabelEl:=TPasElement(LabelElements[j]); + if TypeEl=LabelEl then + exit; // success + end; end; end; + // failed -> show candidates + writeln('CheckDirectReference failed: Labels:'); + for j:=0 to LabelElements.Count-1 do + begin + LabelEl:=TPasElement(LabelElements[j]); + writeln(' Label ',GetObjName(LabelEl),' at ',ResolverEngine.GetElementSourcePosStr(LabelEl)); + end; + writeln('CheckDirectReference failed: References:'); + for i:=0 to ReferenceElements.Count-1 do + begin + El:=TPasElement(ReferenceElements[i]); + writeln(' Reference ',GetObjName(El),' at ',ResolverEngine.GetElementSourcePosStr(El)); + end; + RaiseErrorAt('wrong direct reference "'+aMarker^.Identifier+'"',aMarker); finally + LabelElements.Free; + ReferenceElements.Free; end; - end; var @@ -660,6 +766,7 @@ var i: Integer; SrcLines: TStringList; begin + Module.ForEachCall(@OnCheckElementParent,nil); FirstMarker:=nil; LastMarker:=nil; FoundRefs:=Default(TTestResolverReferenceData); @@ -740,37 +847,50 @@ begin Result:=AddModuleWithSrc(aFilename,Src); end; -procedure TTestResolver.AddSystemUnit; +procedure TTestResolver.AddSystemUnit(Parts: TSystemUnitParts); +var + Intf, Impl: TStringList; begin - AddModuleWithIntfImplSrc('system.pp', - // interface - LinesToStr([ - 'type', - ' integer=longint;', - ' sizeint=int64;', + Intf:=TStringList.Create; + // interface + Intf.Add('type'); + Intf.Add(' integer=longint;'); + Intf.Add(' sizeint=int64;'); //'const', //' LineEnding = #10;', //' DirectorySeparator = ''/'';', //' DriveSeparator = '''';', //' AllowDirectorySeparators : set of char = [''\'',''/''];', //' AllowDriveSeparators : set of char = [];', - 'var', - ' ExitCode: Longint;', + if supTObject in Parts then + begin + Intf.Add('type'); + Intf.Add(' TObject = class'); + Intf.Add(' end;'); + end; + Intf.Add('var'); + Intf.Add(' ExitCode: Longint;'); //'Procedure Move(const source;var dest;count:SizeInt);', - '' - // implementation - ]),LinesToStr([ - // 'Procedure Move(const source;var dest;count:SizeInt);', - // 'begin', - // 'end;', - '' - ])); + + // implementation + Impl:=TStringList.Create; + // 'Procedure Move(const source;var dest;count:SizeInt);', + // 'begin', + // 'end;', + + try + AddModuleWithIntfImplSrc('system.pp',Intf.Text,Impl.Text); + finally + Intf.Free; + Impl.Free; + end; end; -procedure TTestResolver.StartProgram(NeedSystemUnit: boolean); +procedure TTestResolver.StartProgram(NeedSystemUnit: boolean; + SystemUnitParts: TSystemUnitParts); begin if NeedSystemUnit then - AddSystemUnit + AddSystemUnit(SystemUnitParts) else Parser.ImplicitUses.Clear; Add('program '+ExtractFileUnitName(MainFilename)+';'); @@ -846,7 +966,7 @@ var Line, Col: integer; begin ResolverEngine.UnmangleSourceLineNumber(El.SourceLinenumber,Line,Col); - //writeln('TTestResolver.OnFindReference ',GetObjName(El),' ',El.SourceFilename,' Line=',Line,',Col=',Col,' SearchFile=',Data^.Filename,',Line=',Data^.Line,',Col=',Data^.StartCol,'-',Data^.EndCol); + //writeln('TTestResolver.OnFindReference ',El.SourceFilename,' Line=',Line,',Col=',Col,' ',GetObjName(El),' SearchFile=',Data^.Filename,',Line=',Data^.Line,',Col=',Data^.StartCol,'-',Data^.EndCol); if (Data^.Filename=El.SourceFilename) and (Data^.Line=Line) and (Data^.StartCol<=Col) @@ -855,6 +975,60 @@ begin Data^.Found.Add(El); end; +procedure TTestResolver.OnCheckElementParent(data, arg: pointer); +var + SubEl: TPasElement; + El: TPasElement absolute Data; + i: Integer; + + procedure E(Msg: string); + var + s: String; + begin + s:='TTestResolver.OnCheckElementParent El='+GetTreeDesc(El)+' '+ + ResolverEngine.GetElementSourcePosStr(El)+' '+Msg; + writeln('ERROR: ',s); + raise Exception.Create(s); + end; + +begin + if arg=nil then ; + //writeln('TTestResolver.OnCheckElementParent ',GetObjName(El)); + if El is TBinaryExpr then + begin + if (TBinaryExpr(El).left<>nil) and (TBinaryExpr(El).left.Parent<>El) then + E('TBinaryExpr(El).left.Parent='+GetObjName(TBinaryExpr(El).left.Parent)+'<>El'); + if (TBinaryExpr(El).right<>nil) and (TBinaryExpr(El).right.Parent<>El) then + E('TBinaryExpr(El).right.Parent='+GetObjName(TBinaryExpr(El).right.Parent)+'<>El'); + end + else if El is TParamsExpr then + begin + if (TParamsExpr(El).Value<>nil) and (TParamsExpr(El).Value.Parent<>El) then + E('TParamsExpr(El).Value.Parent='+GetObjName(TParamsExpr(El).Value.Parent)+'<>El'); + for i:=0 to length(TParamsExpr(El).Params)-1 do + if TParamsExpr(El).Params[i].Parent<>El then + E('TParamsExpr(El).Params[i].Parent='+GetObjName(TParamsExpr(El).Params[i].Parent)+'<>El'); + end + else if El is TPasDeclarations then + begin + for i:=0 to TPasDeclarations(El).Declarations.Count-1 do + begin + SubEl:=TPasElement(TPasDeclarations(El).Declarations[i]); + if SubEl.Parent<>El then + E('SubEl=TPasElement(TPasDeclarations(El).Declarations[i])='+GetObjName(SubEl)+' SubEl.Parent='+GetObjName(SubEl.Parent)+'<>El'); + end; + end + else if El is TPasImplBlock then + begin + for i:=0 to TPasImplBlock(El).Elements.Count-1 do + begin + SubEl:=TPasElement(TPasImplBlock(El).Elements[i]); + if SubEl.Parent<>El then + E('TPasElement(TPasImplBlock(El).Elements[i]).Parent='+GetObjName(SubEl.Parent)+'<>El'); + end; + end; +end; + function TTestResolver.GetModules(Index: integer): TTestEnginePasResolver; begin Result:=TTestEnginePasResolver(FModules[Index]); @@ -1010,6 +1184,28 @@ begin AssertEquals('c1 expr value','3',ExprC1.Value); end; +procedure TTestResolver.TestDuplicateVar; +var + ok: Boolean; +begin + StartProgram(false); + Add('var a: longint;'); + Add('var a: string;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected duplicate identifier, but got msg number "'+E.Message+'"', + PasResolver.nDuplicateIdentifier,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('duplicate identifier spotted',true,ok); +end; + procedure TTestResolver.TestPrgAssignment; var El: TPasElement; @@ -1373,15 +1569,15 @@ begin Add('begin'); Add(' Func1(3);'); ParseProgram; - AssertEquals('1 declarations',1,PasProgram.ProgramSection.Declarations.Count); + AssertEquals('2 declarations',2,PasProgram.ProgramSection.Declarations.Count); El:=TPasElement(PasProgram.ProgramSection.Declarations[0]); - AssertEquals('overloaded proc',TPasOverloadedProc,El.ClassType); + AssertEquals('is function',TPasFunction,El.ClassType); AssertEquals('1 statement',1,PasProgram.InitializationSection.Elements.Count); end; -procedure TTestResolver.TestProcOverloadRefs; +procedure TTestResolver.TestProcOverloadWithBaseTypes; begin StartProgram(false); Add('function {#A}Func1(i: longint; j: longint = 0): longint; overload;'); @@ -1397,6 +1593,104 @@ begin ParseProgram; end; +procedure TTestResolver.TestProcOverloadWithClassTypes; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class end;'); + Add(' {#TA}TClassA = class end;'); + Add(' {#TB}TClassB = class end;'); + Add('procedure {#DoA}DoIt({=TA}p: TClassA); overload;'); + Add('begin'); + Add('end;'); + Add('procedure {#DoB}DoIt({=TB}p: TClassB); overload;'); + Add('begin'); + Add('end;'); + Add('var'); + Add(' {#A}{=TA}A: TClassA;'); + Add(' {#B}{=TB}B: TClassB;'); + Add('begin'); + Add(' {@DoA}DoIt({@A}A)'); + Add(' {@DoB}DoIt({@B}B)'); + ParseProgram; +end; + +procedure TTestResolver.TestProcOverloadWithInhClassTypes; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class end;'); + Add(' {#TA}TClassA = class end;'); + Add(' {#TB}TClassB = class(TClassA) end;'); + Add(' {#TC}TClassC = class(TClassB) end;'); + Add('procedure {#DoA}DoIt({=TA}p: TClassA); overload;'); + Add('begin'); + Add('end;'); + Add('procedure {#DoB}DoIt({=TB}p: TClassB); overload;'); + Add('begin'); + Add('end;'); + Add('var'); + Add(' {#A}{=TA}A: TClassA;'); + Add(' {#B}{=TB}B: TClassB;'); + Add(' {#C}{=TC}C: TClassC;'); + Add('begin'); + Add(' {@DoA}DoIt({@A}A)'); + Add(' {@DoB}DoIt({@B}B)'); + Add(' {@DoB}DoIt({@C}C)'); + ParseProgram; +end; + +procedure TTestResolver.TestProcOverloadWithInhAliasClassTypes; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class end;'); + Add(' {#TA}TClassA = class end;'); + Add(' {#TB}{=TA}TClassB = TClassA;'); + Add(' {#TC}TClassC = class(TClassB) end;'); + Add('procedure {#DoA}DoIt({=TA}p: TClassA); overload;'); + Add('begin'); + Add('end;'); + Add('procedure {#DoC}DoIt({=TC}p: TClassC); overload;'); + Add('begin'); + Add('end;'); + Add('var'); + Add(' {#A}{=TA}A: TClassA;'); + Add(' {#B}{=TB}B: TClassB;'); + Add(' {#C}{=TC}C: TClassC;'); + Add('begin'); + Add(' {@DoA}DoIt({@A}A)'); + Add(' {@DoA}DoIt({@B}B)'); + Add(' {@DoC}DoIt({@C}C)'); + ParseProgram; +end; + +procedure TTestResolver.TestProcDuplicate; +var + ok: Boolean; +begin + StartProgram(false); + Add('procedure ProcA(i: longint);'); + Add('begin'); + Add('end;'); + Add('procedure ProcA(i: longint);'); + Add('begin'); + Add('end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected duplicate identifier, but got msg number "'+E.Message+'"', + PasResolver.nDuplicateIdentifier,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('duplicate identifier spotted',true,ok); +end; + procedure TTestResolver.TestNestedProc; begin StartProgram(false); @@ -1421,13 +1715,29 @@ begin ParseProgram; end; -procedure TTestResolver.TestDuplicateVar; +procedure TTestResolver.TestForwardProc; +begin + StartProgram(false); + Add('procedure {#A_forward}FuncA(i: longint); forward;'); + Add('procedure {#B}FuncB(i: longint);'); + Add('begin'); + Add(' {@A_forward}FuncA(i);'); + Add('end;'); + Add('procedure {#A}FuncA(i: longint);'); + Add('begin'); + Add('end;'); + Add('begin'); + Add(' {@A}FuncA(3);'); + Add(' {@B}FuncB(3);'); + ParseProgram; +end; + +procedure TTestResolver.TestForwardProcUnresolved; var ok: Boolean; begin StartProgram(false); - Add('var a: longint;'); - Add('var a: string;'); + Add('procedure FuncA(i: longint); forward;'); Add('begin'); ok:=false; try @@ -1435,12 +1745,193 @@ begin except on E: EPasResolve do begin - AssertEquals('Expected duplicate identifier, but got msg number "'+E.Message+'"', + AssertEquals('Expected forward proc not resolved, but got msg number "'+E.Message+'"', + PasResolver.nForwardProcNotResolved,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('unresolved forward proc raised an error',true,ok); +end; + +procedure TTestResolver.TestNestedForwardProc; +begin + StartProgram(false); + Add('procedure {#A}FuncA;'); + Add(' procedure {#B_forward}ProcB(i: longint); forward;'); + Add(' procedure {#C}ProcC(i: longint);'); + Add(' begin'); + Add(' {@B_forward}ProcB(i);'); + Add(' end;'); + Add(' procedure {#B}ProcB(i: longint);'); + Add(' begin'); + Add(' end;'); + Add('begin'); + Add(' {@B}ProcB(3);'); + Add(' {@C}ProcC(3);'); + Add('end;'); + Add('begin'); + Add(' {@A}FuncA;'); + ParseProgram; +end; + +procedure TTestResolver.TestNestedForwardProcUnresolved; +var + ok: Boolean; +begin + StartProgram(false); + Add('procedure FuncA;'); + Add(' procedure ProcB(i: longint); forward;'); + Add('begin'); + Add('end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected forward proc not resolved, but got msg number "'+E.Message+'"', + PasResolver.nForwardProcNotResolved,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('unresolved forward proc raised an error',true,ok); +end; + +procedure TTestResolver.TestForwardProcFuncMismatch; +var + ok: Boolean; +begin + StartProgram(false); + Add('procedure DoIt; forward;'); + Add('function DoIt: longint;'); + Add('begin'); + Add('end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected "procedure expected, but function found", but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('proc type mismatch raised an error',true,ok); +end; + +procedure TTestResolver.TestForwardFuncResultMismatch; +var + ok: Boolean; +begin + StartProgram(false); + Add('function DoIt: longint; forward;'); + Add('function DoIt: string;'); + Add('begin'); + Add('end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected "Result type mismatch", but got msg number "'+E.Message+'"', + PasResolver.nResultTypeMismatchExpectedButFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('function result type mismatch raised an error',true,ok); +end; + +procedure TTestResolver.TestUnitIntfProc; +begin + StartUnit(false); + Add('interface'); + Add('procedure {#A_forward}FuncA(i: longint);'); + Add('implementation'); + Add('procedure {#A}FuncA(i: longint);'); + Add('begin'); + Add('end;'); + Add('initialization'); + Add(' {@A}FuncA(3);'); + ParseUnit; +end; + +procedure TTestResolver.TestUnitIntfProcUnresolved; +var + ok: Boolean; +begin + StartUnit(false); + Add('interface'); + Add('procedure {#A_forward}FuncA(i: longint);'); + Add('implementation'); + Add('initialization'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected forward proc not resolved, but got msg number "'+E.Message+'"', + PasResolver.nForwardProcNotResolved,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('unresolved forward proc raised an error',true,ok); +end; + +procedure TTestResolver.TestUnitIntfMismatchArgName; +var + ok: Boolean; +begin + StartUnit(false); + Add('interface'); + Add('procedure {#A_forward}ProcA(i: longint);'); + Add('implementation'); + Add('procedure {#A}ProcA(j: longint);'); + Add('begin'); + Add('end;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected function header "ProcA" doesn''t match forward : var name changes, but got msg number "'+E.Message+'"', + PasResolver.nFunctionHeaderMismatchForwardVarName,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('mismatch proc argument name raised an error',true,ok); +end; + +procedure TTestResolver.TestProcOverloadIsNotFunc; +var + ok: Boolean; +begin + StartUnit(false); + Add('interface'); + Add('var ProcA: longint;'); + Add('procedure {#A_Decl}ProcA(i: longint);'); + Add('implementation'); + Add('procedure {#A_Impl}ProcA(i: longint);'); + Add('begin'); + Add('end;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected Duplicate identifier, but got msg number "'+E.Message+'"', PasResolver.nDuplicateIdentifier,E.MsgNumber); ok:=true; end; end; - AssertEquals('duplicate identifier spotted',true,ok); + AssertEquals('overload proc/var raised an error',true,ok); end; procedure TTestResolver.TestRecord; @@ -1502,6 +1993,868 @@ begin ParseProgram; end; +procedure TTestResolver.TestClass; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' {#B}b: longint;'); + Add(' end;'); + Add('var'); + Add(' {#C}{=TOBJ}c: TObject;'); + Add('begin'); + Add(' {@C}c.{@b}b:=3;'); + ParseProgram; +end; + +procedure TTestResolver.TestClassDefaultInheritance; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' {#OBJ_a}a: longint;'); + Add(' {#OBJ_b}b: longint;'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' {#A_a}a: longint;'); + Add(' {#A_c}c: longint;'); + Add(' end;'); + Add('var'); + Add(' {#V}{=A}v: TClassA;'); + Add('begin'); + Add(' {@V}v.{@A_c}c:=2;'); + Add(' {@V}v.{@OBJ_b}b:=3;'); + Add(' {@V}v.{@A_a}a:=4;'); + ParseProgram; +end; + +procedure TTestResolver.TestClassTripleInheritance; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' {#OBJ_a}a: longint;'); + Add(' {#OBJ_b}b: longint;'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' {#A_a}a: longint;'); + Add(' {#A_c}c: longint;'); + Add(' end;'); + Add(' {#B}TClassB = class(TClassA)'); + Add(' {#B_a}a: longint;'); + Add(' {#B_d}d: longint;'); + Add(' end;'); + Add('var'); + Add(' {#V}{=B}v: TClassB;'); + Add('begin'); + Add(' {@V}v.{@B_d}d:=1;'); + Add(' {@V}v.{@A_c}c:=2;'); + Add(' {@V}v.{@OBJ_B}b:=3;'); + Add(' {@V}v.{@B_a}a:=4;'); + ParseProgram; +end; + +procedure TTestResolver.TestClassForward; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' end;'); + Add(' {#B_forward}TClassB = class;'); + Add(' {#A}TClassA = class'); + Add(' {#A_a}a: longint;'); + Add(' {#A_b}{=B_forward}b: TClassB;'); + Add(' end;'); + Add(' {#B}TClassB = class(TClassA)'); + Add(' {#B_a}a: longint;'); + Add(' {#B_d}d: longint;'); + Add(' end;'); + Add('var'); + Add(' {#V}{=B}v: TClassB;'); + Add('begin'); + Add(' {@V}v.{@B_d}d:=1;'); + Add(' {@V}v.{@B_a}a:=2;'); + Add(' {@V}v.{@A_b}b:=nil;'); + Add(' {@V}v.{@A_b}b.{@B_a}a:=nil;'); + ParseProgram; +end; + +procedure TTestResolver.TestClassForwardNotResolved; +var + ErrorNo: Integer; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' end;'); + Add(' TClassB = class;'); + Add('var'); + Add(' v: TClassB;'); + Add('begin'); + ErrorNo:=0; + try + ParseModule; + except + on E: EPasResolve do + ErrorNo:=E.MsgNumber; + end; + AssertEquals('Forward class not resolved raises correct error',nForwardTypeNotResolved,ErrorNo); +end; + +procedure TTestResolver.TestClassMethod; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' procedure {#A_ProcA_Decl}ProcA;'); + Add(' end;'); + Add('procedure TClassA.ProcA;'); + Add('begin'); + Add('end;'); + Add('var'); + Add(' {#V}{=A}v: TClassA;'); + Add('begin'); + Add(' {@V}v.{@A_ProcA_Decl}ProcA;'); + ParseProgram; +end; + +procedure TTestResolver.TestClassMethodUnresolved; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' end;'); + Add(' TClassA = class'); + Add(' procedure ProcA;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected forward proc not resolved, but got msg number "'+E.Message+'"', + PasResolver.nForwardProcNotResolved,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('unresolved forward proc raised an error',true,ok); +end; + +procedure TTestResolver.TestClassMethodAbstract; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure ProcA; virtual; abstract;'); + Add(' end;'); + Add('begin'); + ParseProgram; +end; + +procedure TTestResolver.TestClassMethodAbstractWithoutVirtual; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure ProcA; abstract;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected abstract without virtual, but got msg number "'+E.Message+'"', + PasResolver.nInvalidProcModifiers,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('abstract method without virtual raised an error',true,ok); +end; + +procedure TTestResolver.TestClassMethodAbstractHasBody; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure ProcA; virtual; abstract;'); + Add(' end;'); + Add('procedure TObject.ProcA;'); + Add('begin'); + Add('end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected abstract must not have implementation, but got msg number "'+E.Message+'"', + PasResolver.nAbstractMethodsMustNotHaveImplementation,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('abstract method with body raised an error',true,ok); +end; + +procedure TTestResolver.TestClassMethodUnresolvedWithAncestor; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure ProcA; virtual; abstract;'); + Add(' end;'); + Add(' TClassA = class'); + Add(' procedure ProcA;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected forward proc not resolved, but got msg number "'+E.Message+'"', + PasResolver.nForwardProcNotResolved,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('unresolved forward proc raised an error',true,ok); +end; + +procedure TTestResolver.TestClassProcFuncMismatch; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure DoIt;'); + Add(' end;'); + Add('function TObject.DoIt: longint;'); + Add('begin'); + Add('end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected "procedure expected, but function found", but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('proc type mismatch raised an error',true,ok); +end; + +procedure TTestResolver.TestClassMethodOverload; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure DoIt;'); + Add(' procedure DoIt(i: longint);'); + Add(' procedure DoIt(s: string);'); + Add(' end;'); + Add('procedure TObject.DoIt;'); + Add('begin'); + Add('end;'); + Add('procedure TObject.DoIt(i: longint);'); + Add('begin'); + Add('end;'); + Add('procedure TObject.DoIt(s: string);'); + Add('begin'); + Add('end;'); + Add('begin'); + ParseProgram; +end; + +procedure TTestResolver.TestClassMethodInvalidOverload; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure DoIt(i: longint);'); + Add(' procedure DoIt(k: longint);'); + Add(' end;'); + Add('procedure TObject.DoIt(i: longint);'); + Add('begin'); + Add('end;'); + Add('procedure TObject.DoIt(k: longint);'); + Add('begin'); + Add('end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected Duplicate identifier, but got msg number "'+E.Message+'"', + PasResolver.nDuplicateIdentifier,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('duplicate method signature raised an error',true,ok); +end; + +procedure TTestResolver.TestClassOverride; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure {#TOBJ_ProcA}ProcA; virtual; abstract;'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' procedure {#A_ProcA}ProcA; override;'); + Add(' end;'); + Add('procedure TClassA.ProcA;'); + Add('begin'); + Add('end;'); + Add('var'); + Add(' {#V}{=A}v: TClassA;'); + Add('begin'); + Add(' {@V}v.{@A_ProcA}ProcA;'); + ParseProgram; +end; + +procedure TTestResolver.TestClassMethodScope; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' {#A_A}A: longint;'); + Add(' procedure {#A_ProcB}ProcB;'); + Add(' end;'); + Add('procedure TClassA.ProcB;'); + Add('begin'); + Add(' {@A_A}A:=3;'); + Add('end;'); + Add('begin'); + ParseProgram; +end; + +procedure TTestResolver.TestClassIdentifierSelf; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' {#C}C: longint;'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' {#B}B: longint;'); + Add(' procedure {#A_ProcB}ProcB;'); + Add(' end;'); + Add('procedure TClassA.ProcB;'); + Add('begin'); + Add(' {@B}B:=1;'); + Add(' {@C}C:=2;'); + Add(' {@A}Self.{@B}B:=3;'); + Add('end;'); + Add('begin'); + ParseProgram; +end; + +procedure TTestResolver.TestClassCallInherited; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure {#TOBJ_ProcA}ProcA(i: longint);'); + Add(' procedure {#TOBJ_ProcB}ProcB(j: longint);'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' procedure {#A_ProcA}ProcA(i: longint);'); + Add(' procedure {#A_ProcB}ProcB(k: longint);'); + Add(' end;'); + Add('procedure TObject.ProcA(i: longint);'); + Add('begin'); + Add(' inherited; // ignore and do not raise error'); + Add('end;'); + Add('procedure TObject.ProcB(j: longint);'); + Add('begin'); + Add('end;'); + Add('procedure TClassA.ProcA({#i1}i: longint);'); + Add('begin'); + Add(' {@A_ProcA}ProcA;'); + Add(' {@TOBJ_ProcA}inherited;'); + Add(' inherited {@TOBJ_ProcA}ProcA({@i1}i);'); + Add(' {@A_ProcB}ProcB;'); + Add(' inherited {@TOBJ_ProcB}ProcB({@i1}i);'); + Add('end;'); + Add('procedure TClassA.ProcB(k: longint);'); + Add('begin'); + Add('end;'); + Add('begin'); + ParseProgram; +end; + +procedure TTestResolver.TestProperty1; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' {#FB}FB: longint;'); + Add(' property {#B}B: longint read {@FB}FB write {@FB}FB;'); + Add(' end;'); + Add('var'); + Add(' {#v}{=A}v: TClassA;'); + Add('begin'); + Add(' {@v}v.{@b}b:=3;'); + ParseProgram; +end; + +procedure TTestResolver.TestPropertyAccessorNotInFront; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' property B: longint read FB;'); + Add(' FB: longint;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected Identifier not found, but got msg number "'+E.Message+'"', + PasResolver.nIdentifierNotFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('property accessor not in front raised an error',true,ok); +end; + +procedure TTestResolver.TestPropertyReadAccessorVarWrongType; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' FB: string;'); + Add(' property B: longint read FB;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected Longint expected, but String found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('property read accessor wrong type raised an error',true,ok); +end; + +procedure TTestResolver.TestPropertyReadAccessorProcNotFunc; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure GetB;'); + Add(' property B: longint read GetB;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected function expected, but procedure found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('property read accessor wrong function type raised an error',true,ok); +end; + +procedure TTestResolver.TestPropertyReadAccessorFuncWrongResult; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' function GetB: string;'); + Add(' property B: longint read GetB;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected function result longint expected, but function result string found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('property read accessor function wrong result type raised an error',true,ok); +end; + +procedure TTestResolver.TestPropertyReadAccessorFuncWrongArgCount; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' function GetB(i: longint): string;'); + Add(' property B: longint read GetB;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected function arg count 0 expected, but 1 found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('property read accessor function wrong arg count raised an error',true,ok); +end; + +procedure TTestResolver.TestPropertyReadAccessorFunc; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' function {#GetB}GetB: longint;'); + Add(' property {#B}B: longint read {@GetB}GetB;'); + Add(' end;'); + Add('function TObject.GetB: longint;'); + Add('begin'); + Add('end;'); + Add('var'); + Add(' {#o}{=TOBJ}o: TObject;'); + Add('begin'); + Add(' {@o}o.{@B}B:=3;'); + ParseProgram; +end; + +procedure TTestResolver.TestPropertyWriteAccessorVarWrongType; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' FB: string;'); + Add(' property B: longint write FB;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected Longint expected, but String found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('property read accessor wrong type raised an error',true,ok); +end; + +procedure TTestResolver.TestPropertyWriteAccessorFuncNotProc; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' function SetB: longint;'); + Add(' property B: longint write SetB;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected procedure expected, but function found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('property write accessor wrong function instead of proc raised an error',true,ok); +end; + +procedure TTestResolver.TestPropertyWriteAccessorProcWrongArgCount; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure SetB;'); + Add(' property B: longint write SetB;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected procedure arg count 1 expected, but 0 found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('property write accessor procedure wrong arg count raised an error',true,ok); +end; + +procedure TTestResolver.TestPropertyWriteAccessorProcWrongArg; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure SetB(var Value: longint);'); + Add(' property B: longint write SetB;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected procedure arg longint expected, but var found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('property write accessor procedure wrong arg type raised an error',true,ok); +end; + +procedure TTestResolver.TestPropertyWriteAccessorProcWrongArgType; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure SetB(Value: string);'); + Add(' property B: longint write SetB;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected procedure(Value: longint) expected, but procedure(Value: string) found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('property write accessor procedure wrong arg type raised an error',true,ok); +end; + +procedure TTestResolver.TestPropertyWriteAccessorProc; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' procedure {#SetB}SetB(Value: longint);'); + Add(' property {#B}B: longint write {@SetB}SetB;'); + Add(' end;'); + Add('procedure TObject.SetB(Value: longint);'); + Add('begin'); + Add('end;'); + Add('var'); + Add(' {#o}{=TOBJ}o: TObject;'); + Add('begin'); + Add(' {@o}o.{@B}B:=3;'); + ParseProgram; +end; + +procedure TTestResolver.TestPropertyTypeless; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' {#FB}FB: longint;'); + Add(' property {#TOBJ_B}B: longint read {@FB}FB;'); + Add(' end;'); + Add(' {#TA}TClassA = class'); + Add(' {#FC}FC: longint;'); + Add(' property {#TA_B}{@TOBJ_B}B read {@FC}FC;'); + Add(' end;'); + Add('var'); + Add(' {#v}{=TA}v: TClassA;'); + Add('begin'); + Add(' {@v}v.{@TA_B}B:=3;'); + ParseProgram; +end; + +procedure TTestResolver.TestPropertyTypelessNoAncestor; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' end;'); + Add(' TClassA = class'); + Add(' property B;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected no property found to override, but got msg number "'+E.Message+'"', + PasResolver.nNoPropertyFoundToOverride,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('property typeless without ancestor property raised an error',true,ok); +end; + +procedure TTestResolver.TestPropertyStoredAccessorProcNotFunc; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' FB: longint;'); + Add(' procedure GetB;'); + Add(' property B: longint read FB stored GetB;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected function expected, but procedure found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('property stored accessor wrong function type raised an error',true,ok); +end; + +procedure TTestResolver.TestPropertyStoredAccessorFuncWrongResult; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' FB: longint;'); + Add(' function GetB: string;'); + Add(' property B: longint read FB stored GetB;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected function result longint expected, but function result string found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('property stored accessor function wrong result type raised an error',true,ok); +end; + +procedure TTestResolver.TestPropertyStoredAccessorFuncWrongArgCount; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' FB: longint;'); + Add(' function GetB(i: longint): boolean;'); + Add(' property B: longint read FB stored GetB;'); + Add(' end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected function arg count 0 expected, but 1 found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('property stored accessor function wrong arg count raised an error',true,ok); +end; + +procedure TTestResolver.TestPropertyArgs1; +begin + exit; + + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' function GetB(Index: longint): boolean;'); + Add(' procedure SetB(Index: longint; Value: longint);'); + Add(' property B[Index: longint]: longint read GetB write SetB;'); + Add(' end;'); + Add('function TObject.GetB(Index: longint): boolean;'); + Add('begin'); + Add('end;'); + Add('procedure TObject.SetB(Index: longint; Value: longint);'); + Add('begin'); + Add('end;'); + Add('begin'); + ParseProgram; +end; + initialization RegisterTests([TTestResolver]); diff --git a/packages/fcl-passrc/tests/tctypeparser.pas b/packages/fcl-passrc/tests/tctypeparser.pas index a07437bd95..ec1f1be97a 100644 --- a/packages/fcl-passrc/tests/tctypeparser.pas +++ b/packages/fcl-passrc/tests/tctypeparser.pas @@ -154,6 +154,7 @@ type Procedure TestReferenceFile; Procedure TestReferenceArray; Procedure TestReferencePointer; + Procedure TestInvalidColon; end; { TTestRecordTypeParser } @@ -3183,6 +3184,19 @@ begin AssertSame('Second declaration references first.',Declarations.Types[0],TPasPointerType(Declarations.Types[1]).DestType); end; +procedure TTestTypeParser.TestInvalidColon; +var + ok: Boolean; +begin + ok:=false; + try + ParseType(':1..2',TPasSetType); + except + on E: EParserError do + ok:=true; + end; + AssertEquals('wrong colon in type raised an error',true,ok); +end; initialization RegisterTests([TTestTypeParser,TTestRecordTypeParser,TTestProcedureTypeParser]); diff --git a/packages/pastojs/tests/tcconverter.pp b/packages/pastojs/tests/tcconverter.pp index ba1f068144..9bf3c7abf4 100644 --- a/packages/pastojs/tests/tcconverter.pp +++ b/packages/pastojs/tests/tcconverter.pp @@ -333,11 +333,6 @@ begin AssertEquals('Correct condition class',TJSUnaryNotExpression,E.Cond.ClassType); AssertIdentifier('Conditional expression',TJSUnaryNotExpression(E.Cond).A,'a'); L:=AssertListStatement('Multiple statements',E.Body); - // writeln('TTestStatementConverter.TestRepeatUntilStatementTwo L.A=',L.A.ClassName); - // writeln(' L.B=',L.B.ClassName); - // writeln(' L.B.A=',TJSStatementList(L.B).A.ClassName); - // writeln(' L.B.B=',TJSStatementList(L.B).B.ClassName); - AssertAssignStatement('First List statement is assignment',L.A,'b','c'); AssertAssignStatement('Second List statement is assignment',L.B,'d','e'); end;