diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 4f9d7c63c1..8cbbd57559 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -32,12 +32,12 @@ - unitname.identifier - alias types, 'type a=b' - type alias type 'type a=type b' - - choose the compatible overloaded procedure - - while do - - repeat until - - if then else + - choose the most compatible overloaded procedure + - while..do + - repeat..ntil + - if..then..else - binary operators - - case of + - case..of - try..finally..except, on, else, raise - for loop - spot duplicates @@ -53,18 +53,19 @@ - read var, read function - write var, write function - stored function + - is and as operator + - nil + - with..do ToDo: - - add global error ids - classes - TPasClassType - - tests for ancestor TPasAliasType - - class methods - - property indexed + - property with params + - typecast - class of + - class method, property, var, const - visibility - nested var, const - nested types - - with - TPasImplWithDo - procedure type - method type - records - TPasRecordType, @@ -74,18 +75,19 @@ - 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 - pointer TPasPointerType + - proc: check if forward and impl default values match + - for..in..do - untyped parameters - sets - TPasSetType - forwards of ^pointer and class of - must be queued and resolved at end of type section - interfaces - properties - TPasProperty - - read, write, index properties, implements, stored + - index properties, implements, stored, default - default property - TPasResString - TPasFileType @@ -142,6 +144,11 @@ const nInheritedOnlyWorksInMethods = 3023; nInheritedNeedsAncestor = 3024; nNoPropertyFoundToOverride = 3025; + nExprTypeMustBeClassOrRecordTypeGot = 3026; + nPropertyNotWritable = 3027; + nIncompatibleTypeGotExpected = 3028; + nTypesAreNotRelated = 3029; + nAbstractMethodsCannotBeCalledDirectly = 3030; // resourcestring patterns of messages resourcestring @@ -170,11 +177,17 @@ resourcestring sInheritedOnlyWorksInMethods = 'Inherited works only in methods'; sInheritedNeedsAncestor = 'inherited needs an ancestor'; sNoPropertyFoundToOverride = 'No property found to override'; + sExprTypeMustBeClassOrRecordTypeGot = 'Expression type must be class or record type, got %s'; + sPropertyNotWritable = 'No member is provided to access property'; + sIncompatibleTypeGotExpected = 'Incompatible types: got "%s" expected "%s"'; + sTypesAreNotRelated = 'Types are not related'; + sAbstractMethodsCannotBeCalledDirectly = 'Abstract methods cannot be called directly'; type - TResolveBaseType = ( + TResolverBaseType = ( btNone, // undefined - btContext, // a TPasType + btContext, // a class or record + btModule, btUntyped, // TPasArgument without ArgType btChar, // char btWideChar, // widechar @@ -208,12 +221,11 @@ type btFile, // file btText, // text btVariant, // variant - btNil, // nil = pointer, class, procedure, method, ... - btCompilerFunc// SUCC, PREC, LOW, HIGH, ORD, LENGTH, COPY + btNil // nil = pointer, class, procedure, method, ... ); - TResolveBaseTypes = set of TResolveBaseType; + TResolveBaseTypes = set of TResolverBaseType; const - btAllNumbers = [btComp,btCurrency,btByte,btShortInt,btWord,btSmallInt, + btAllInteger = [btComp,btCurrency,btByte,btShortInt,btWord,btSmallInt, btLongWord,btCardinal,btLongint,btQWord,btInt64]; btAllStrings = [btChar,btWideChar,btString,btAnsiString,btShortString, btWideString,btUnicodeString]; @@ -251,12 +263,14 @@ const btPointer, btFile, btText, - btVariant + btVariant, + btNil ]; - BaseTypeNames: array[TResolveBaseType] of shortstring =( + BaseTypeNames: array[TResolverBaseType] of shortstring =( 'None', 'Context', + 'Module', 'Untyped', 'Char', 'WideChar', @@ -290,10 +304,22 @@ const 'File', 'Text', 'Variant', - 'Nil', - 'CompilerFunc' + 'Nil' ); +type + TResolverBuiltInProc = ( + bfLength, // function length(const dynarray or string): sizeint + bfSetLength // procedure SetLength(var dynarray or string,sizeint) + ); + TResolverBuiltInProcs = set of TResolverBuiltInProc; +const + ResolverBuiltInProcNames: array[TResolverBuiltInProc] of shortstring = ( + 'Length', + 'SetLength' + ); + bfAllStandardProcs = [low(TResolverBuiltInProc)..high(TResolverBuiltInProc)]; + const ResolverResultVar = 'Result'; @@ -328,6 +354,13 @@ type end; TResolveDataClass = class of TResolveData; + TPasWithExprScope = class; + + TResolvedReferenceFlag = ( + rrfVMT // use VMT for call + ); + TResolvedReferenceFlags = set of TResolvedReferenceFlag; + { TResolvedReference - CustomData for normal references } TResolvedReference = Class(TResolveData) @@ -335,20 +368,33 @@ type FDeclaration: TPasElement; procedure SetDeclaration(AValue: TPasElement); public + WithExprScope: TPasWithExprScope; + Flags: TResolvedReferenceFlags; destructor Destroy; override; property Declaration: TPasElement read FDeclaration write SetDeclaration; end; - { TResolvedCustom - CustomData for compiler built-in identifiers like 'length' } - - TResolvedCustom = Class(TResolveData) + TResElDataBuiltInSymbol = Class(TResolveData) public - //pas2js creates descendants of this + end; + + { TResElDataBaseType - CustomData for compiler built-in types, e.g. longint } + + TResElDataBaseType = Class(TResElDataBuiltInSymbol) + public + BaseType: TResolverBaseType; + end; + + { TResElDataBuiltInProc - CustomData for compiler built-in procs like 'length' } + + TResElDataBuiltInProc = Class(TResElDataBuiltInSymbol) + public + Proc: TResElDataBuiltInProc; end; TPasScope = class; - TIterateScopeElement = procedure(El: TPasElement; Scope: TPasScope; + TIterateScopeElement = procedure(El: TPasElement; ElScope, StartScope: TPasScope; Data: Pointer; var Abort: boolean) of object; { TPasScope - CustomData for elements with sub identifiers } @@ -356,7 +402,8 @@ type TPasScope = Class(TResolveData) public class function IsStoredInElement: boolean; virtual; - procedure IterateElements(const aName: string; + class function FreeOnPop: boolean; virtual; + procedure IterateElements(const aName: string; StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); virtual; procedure WriteIdentifiers(Prefix: string); virtual; @@ -367,14 +414,15 @@ type TPasModuleScope = class(TPasScope) public - procedure IterateElements(const aName: string; + procedure IterateElements(const aName: string; StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); override; end; TPasIdentifierKind = ( pikNone, // not yet initialized - pikCustom, // built-in identifiers + pikBaseType, // e.g. longint + pikBuiltInProc, // e.g. High(), SetLength() pikSimple, // simple vars, consts, types, enums pikProc // may need parameter list with round brackets { @@ -391,6 +439,9 @@ type FElement: TPasElement; procedure SetElement(AValue: TPasElement); public + {$IFDEF VerbosePasResolver} + Owner: TObject; + {$ENDIF} Identifier: String; NextSameIdentifier: TPasIdentifier; // next identifier with same name Kind: TPasIdentifierKind; @@ -403,6 +454,7 @@ type TPasIdentifierScope = Class(TPasScope) private FItems: TFPHashList; + function InternalFindIdentifier(const Identifier: String): TPasIdentifier; inline; procedure InternalAdd(Item: TPasIdentifier); procedure OnClearItem(Item, Dummy: pointer); procedure OnWriteItem(Item, Dummy: pointer); @@ -412,9 +464,9 @@ type function FindIdentifier(const Identifier: String): TPasIdentifier; virtual; function RemoveIdentifier(El: TPasElement): boolean; virtual; function AddIdentifier(const Identifier: String; El: TPasElement; - const Kind: TPasIdentifierKind): TPasIdentifier; + const Kind: TPasIdentifierKind): TPasIdentifier; virtual; function FindElement(const aName: string): TPasElement; - procedure IterateElements(const aName: string; + procedure IterateElements(const aName: string; StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); override; procedure WriteIdentifiers(Prefix: string); override; @@ -436,9 +488,10 @@ type destructor Destroy; override; function FindIdentifierInSection(const Identifier: String): TPasIdentifier; function FindIdentifier(const Identifier: String): TPasIdentifier; override; - procedure IterateElements(const aName: string; + procedure IterateElements(const aName: string; StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); override; + procedure WriteIdentifiers(Prefix: string); override; end; { TPasRecordScope } @@ -454,9 +507,10 @@ type AncestorScope: TPasClassScope; DirectAncestor: TPasType; // TPasClassType or TPasAliasType or TPasTypeAliasType function FindIdentifier(const Identifier: String): TPasIdentifier; override; - procedure IterateElements(const aName: string; + procedure IterateElements(const aName: string; StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); override; + procedure WriteIdentifiers(Prefix: string); override; end; { TPasProcedureScope } @@ -468,9 +522,10 @@ type 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; + procedure IterateElements(const aName: string; StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); override; + procedure WriteIdentifiers(Prefix: string); override; end; { TPasExceptOnScope } @@ -478,6 +533,35 @@ type TPasExceptOnScope = Class(TPasIdentifierScope) end; + TPasWithScope = class; + + { TPasWithExprScope } + + TPasWithExprScope = Class(TPasScope) + public + WithScope: TPasWithScope; + Index: integer; + NeedTmpVar: boolean; + Expr: TPasExpr; + Scope: TPasScope; + class function IsStoredInElement: boolean; override; + class function FreeOnPop: boolean; override; + procedure IterateElements(const aName: string; StartScope: TPasScope; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); override; + procedure WriteIdentifiers(Prefix: string); override; + end; + + { TPasWithScope } + + TPasWithScope = Class(TPasScope) + public + // Element is the TPasImplWithDo + ExpressionScopes: TObjectList; // list of TPasWithExprScope + constructor Create; override; + destructor Destroy; override; + end; + { TPasSubScope - base class for sub scopes aka dotted scopes } TPasSubScope = Class(TPasIdentifierScope) @@ -498,7 +582,7 @@ type TPasSubModuleScope = Class(TPasSubScope) private FCurModule: TPasModule; - procedure OnInternalIterate(El: TPasElement; Scope: TPasScope; + procedure OnInternalIterate(El: TPasElement; ElScope, StartScope: TPasScope; Data: Pointer; var Abort: boolean); procedure SetCurModule(AValue: TPasModule); public @@ -506,9 +590,10 @@ type ImplementationScope: TPasSectionScope; destructor Destroy; override; function FindIdentifier(const Identifier: String): TPasIdentifier; override; - procedure IterateElements(const aName: string; + procedure IterateElements(const aName: string; StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); override; + procedure WriteIdentifiers(Prefix: string); override; property CurModule: TPasModule read FCurModule write SetCurModule; end; @@ -518,9 +603,10 @@ type public RecordScope: TPasRecordScope; function FindIdentifier(const Identifier: String): TPasIdentifier; override; - procedure IterateElements(const aName: string; + procedure IterateElements(const aName: string; StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); override; + procedure WriteIdentifiers(Prefix: string); override; end; { TPasDotClassScope - used for aClass.subidentifier } @@ -528,37 +614,48 @@ type TPasDotClassScope = Class(TPasSubScope) public ClassScope: TPasClassScope; + InheritedExpr: boolean; // this is 'inherited ' instead of '., IdentEl might be nil - rkPointer // @, pointer of TypeEl - ); + { TPasResolverResult } - TPasResolvedType = record - Kind: TPasResolvedKind; - BaseType: TResolveBaseType; - IdentEl: TPasElement; - TypeEl: TPasType; + TPasResolverResult = record + BaseType: TResolverBaseType; + IdentEl: TPasElement; // if set then this specific identifier is the value, can be a type + TypeEl: TPasType; // can be nil for const expression ExprEl: TPasExpr; end; - PPasResolvedType = ^TPasResolvedType; + PPasResolvedElement = ^TPasResolverResult; + + TPasResolverComputeFlag = ( + rcSkipTypeAlias + ); + TPasResolverComputeFlags = set of TPasResolverComputeFlag; + + TPRFindFirstData = record + ErrorPosEl: TPasElement; + Found: TPasElement; + ElScope, StartScope: TPasScope; + end; + PPRFindFirstData = ^TPRFindFirstData; { TPasResolver } TPasResolver = Class(TPasTreeContainer) private + type + TResolveDataListKind = (lkBuiltIn,lkModule); + procedure ClearResolveDataList(Kind: TResolveDataListKind); + private + FBaseTypes: array[TResolverBaseType] of TPasUnresolvedSymbolRef; FDefaultScope: TPasDefaultScope; FLastElement: TPasElement; - FLastCreatedData: TResolveData; + FLastCreatedData: array[TResolveDataListKind] of TResolveData; FLastMsg: string; FLastMsgArgs: TMessageArgs; FLastMsgElement: TPasElement; @@ -573,16 +670,8 @@ type FRootElement: TPasElement; FTopScope: TPasScope; FPendingForwards: TFPList; // list of TPasElement needed to check for forwards + function GetBaseType(bt: TResolverBaseType): TPasUnresolvedSymbolRef; inline; function GetScopes(Index: integer): TPasScope; inline; - protected - type - TFindFirstElementData = record - ErrorPosEl: TPasElement; - Found: TPasElement; - end; - PFindFirstElementData = ^TFindFirstElementData; - procedure OnFindFirstElement(El: TPasElement; Scope: TPasScope; - FindFirstElementData: Pointer; var Abort: boolean); virtual; protected const cIncompatible = High(integer); @@ -591,6 +680,7 @@ type TFindCallProcData = record Params: TParamsExpr; Found: TPasProcedure; + ElScope, StartScope: TPasScope; Distance: integer; // compatibility distance Count: integer; List: TFPList; // if not nil then collect all found proc here @@ -602,14 +692,16 @@ type Args: TFPList; // List of TPasArgument objects OnlyScope: TPasScope; Found: TPasProcedure; - FoundInScope: TPasScope; + ElScope, StartScope: TPasScope; FoundNonProc: TPasElement; end; PFindOverloadProcData = ^TFindOverloadProcData; - procedure OnFindCallProc(El: TPasElement; Scope: TPasScope; + procedure OnFindFirstElement(El: TPasElement; ElScope, StartScope: TPasScope; + FindFirstElementData: Pointer; var Abort: boolean); virtual; + procedure OnFindCallProc(El: TPasElement; ElScope, StartScope: TPasScope; FindProcsData: Pointer; var Abort: boolean); virtual; - procedure OnFindOverloadProc(El: TPasElement; Scope: TPasScope; + procedure OnFindOverloadProc(El: TPasElement; ElScope, StartScope: TPasScope; FindOverloadData: Pointer; var Abort: boolean); virtual; protected procedure SetCurrentParser(AValue: TPasParser); override; @@ -628,6 +720,22 @@ type procedure AddArgument(El: TPasArgument); procedure AddFunctionResult(El: TPasResultElement); procedure AddExceptOn(El: TPasImplExceptOn); + procedure ResolveImplBlock(Block: TPasImplBlock); + procedure ResolveImplElement(El: TPasImplElement); + procedure ResolveImplCaseOf(CaseOf: TPasImplCaseOf); + procedure ResolveImplLabelMark(Mark: TPasImplLabelMark); + procedure ResolveImplForLoop(Loop: TPasImplForLoop); + procedure ResolveImplWithDo(El: TPasImplWithDo); + procedure ResolveImplAssign(El: TPasImplAssign); + procedure ResolveImplRaise(El: TPasImplRaise); + procedure ResolveExpr(El: TPasExpr); + procedure ResolveBooleanExpr(El: TPasExpr); + procedure ResolveNameExpr(El: TPasExpr; const aName: string); + procedure ResolveInherited(El: TInheritedExpr); + procedure ResolveInheritedCall(El: TBinaryExpr); + procedure ResolveBinaryExpr(El: TBinaryExpr); + procedure ResolveSubIdent(El: TBinaryExpr); + procedure ResolveParamsExpr(Params: TParamsExpr); procedure StartProcedureBody(El: TProcedureBody); procedure FinishModule(CurModule: TPasModule); procedure FinishUsesList; @@ -643,22 +751,15 @@ type 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; + procedure ComputeBinaryExpr(Bin: TBinaryExpr; + out ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags); + procedure CheckIsClass(El: TPasElement; const ResolvedEl: TPasResolverResult); public constructor Create; destructor Destroy; override; + procedure Clear; virtual; // does not free built-in identifiers + // overrides of TPasTreeContainer function CreateElement(AClass: TPTreeElement; const AName: String; AParent: TPasElement; AVisibility: TPasMemberVisibility; const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement; @@ -667,53 +768,81 @@ type AParent: TPasElement; AVisibility: TPasMemberVisibility; const ASrcPos: TPasSourcePos): TPasElement; overload; override; - function FindElement(const AName: String): TPasElement; override; + function FindElement(const AName: String): TPasElement; override; // used by TPasParser function FindFirstElement(const AName: String; ErrorPosEl: TPasElement): TPasElement; + function FindFirstElement(const AName: String; out Data: TPRFindFirstData; + ErrorPosEl: TPasElement): TPasElement; procedure IterateElements(const aName: string; const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); virtual; procedure FinishScope(ScopeType: TPasScopeType; El: TPasElement); override; - class procedure UnmangleSourceLineNumber(LineNumber: integer; - out Line, Column: integer); - 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; + // built in types and functions + procedure ClearBuiltInIdentifiers; + procedure AddObjFPCBuiltInIdentifiers( + BaseTypes: TResolveBaseTypes = btAllStandardTypes; + BaseProcs: TResolverBuiltInProcs = bfAllStandardProcs); + function AddBaseType(aName: shortstring; Typ: TResolverBaseType): TResElDataBaseType; + function IsBaseType(aType: TPasType; BaseType: TResolverBaseType): boolean; + function AddBuiltInProc(aName: shortstring): TResElDataBuiltInProc; + // add extra TResolveData (E.CustomData) to free list + procedure AddResolveData(El: TPasElement; Data: TResolveData; + Kind: TResolveDataListKind); + function CreateReference(DeclEl, RefEl: TPasElement; + FindData: PPRFindFirstData = nil): TResolvedReference; virtual; + // scopes 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; + function PushScope(El: TPasElement; ScopeClass: TPasScopeClass): TPasScope; overload; + function PushClassDotScope(var CurClassType: TPasClassType): TPasDotClassScope; + function PushRecordDotScope(CurRecordType: TPasRecordType): TPasDotRecordScope; + function PushDotScopeForType(TypeEl: TPasType; ErrorEl: TPasElement): TPasSubScope; procedure ResetSubScopes(out Depth: integer); procedure RestoreSubScopes(Depth: integer); + // log and messages + class procedure UnmangleSourceLineNumber(LineNumber: integer; + out Line, Column: integer); + class function GetElementSourcePosStr(El: TPasElement): string; 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 RaiseNotYetImplemented(id: int64; El: TPasElement; Msg: string = ''); virtual; + procedure RaiseInternalError(id: int64; const Msg: string = ''); + procedure RaiseInvalidScopeForElement(id: int64; El: TPasElement; const Msg: string = ''); procedure RaiseIdentifierNotFound(Identifier: string; El: TPasElement); procedure RaiseXExpectedButYFound(X,Y: string; El: TPasElement); + procedure WriteScopes; + // find value and type of an element + procedure ComputeElement(El: TPasElement; out ResolvedEl: TPasResolverResult; + Flags: TPasResolverComputeFlags); + // checking compatibilility function CheckCallProcCompatibility(Proc: TPasProcedure; Params: TParamsExpr; RaiseOnError: boolean): integer; function CheckParamCompatibility(Expr: TPasExpr; Param: TPasArgument; ParamNo: integer; RaiseOnError: boolean): integer; function CheckCustomTypeCompatibility( - const SrcType, DestType: TPasResolvedType; ErrorEl: TPasElement): integer; + const SrcType, DestType: TPasResolverResult; ErrorEl: TPasElement): integer; function CheckSrcIsADstType( - const ResolvedSrcType, ResolvedDestType: TPasResolvedType; + const ResolvedSrcType, ResolvedDestType: TPasResolverResult; 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 CheckCanBeLHS(const ResolvedEl: TPasResolverResult; + ErrorOnFalse: boolean; ErrorEl: TPasElement): boolean; + function CheckAssignCompatibility(const LHS, RHS: TPasResolverResult; + ErrorEl: TPasElement): integer; + // uility functions + function GetPasPropertyType(El: TPasProperty): TPasType; + function GetPasPropertyAncestor(El: TPasProperty): TPasProperty; + function GetPasPropertyGetter(El: TPasProperty): TPasElement; + function GetPasPropertySetter(El: TPasProperty): TPasElement; function GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType; public + property BaseType[bt: TResolverBaseType]: TPasUnresolvedSymbolRef read GetBaseType; property LastElement: TPasElement read FLastElement; property StoreSrcColumns: boolean read FStoreSrcColumns write FStoreSrcColumns; { If true Line and Column is mangled together in TPasElement.SourceLineNumber. @@ -735,12 +864,12 @@ function GetObjName(o: TObject): string; function GetProcDesc(Proc: TPasProcedure): string; function GetTypeDesc(aType: TPasType): string; function GetTreeDesc(El: TPasElement; Indent: integer = 0): string; -function GetResolvedTypeDesc(const T: TPasResolvedType): string; -procedure SetResolvedType(out ResolvedType: TPasResolvedType; - Kind: TPasResolvedKind; BaseType: TResolveBaseType; IdentEl: TPasElement; +function GetResolverResultDesc(const T: TPasResolverResult): string; +procedure SetResolverIdentifier(out ResolvedType: TPasResolverResult; + BaseType: TResolverBaseType; IdentEl: TPasElement; TypeEl: TPasType); overload; -procedure SetResolvedTypeExpr(out ResolvedType: TPasResolvedType; - BaseType: TResolveBaseType; ExprEl: TPasExpr); overload; +procedure SetResolverTypeExpr(out ResolvedType: TPasResolverResult; + BaseType: TResolverBaseType; TypeEl: TPasType; ExprEl: TPasExpr); overload; function ProcNeedsImplProc(Proc: TPasProcedure): boolean; implementation @@ -933,36 +1062,48 @@ begin end; end; -function GetResolvedTypeDesc(const T: TPasResolvedType): string; +function GetResolverResultDesc(const T: TPasResolverResult): string; begin - case T.Kind of - rkNone: Result:=''; - rkIdentifier: Result:=GetObjName(T.IdentEl)+':'+GetTypeDesc(T.TypeEl as TPasType)+'='+BaseTypeNames[T.BaseType]; - rkExpr: Result:=GetTreeDesc(T.ExprEl)+'='+BaseTypeNames[T.BaseType]; - rkArrayOf: Result:='array of '+GetTypeDesc(T.TypeEl as TPasType)+'='+BaseTypeNames[T.BaseType]; - rkPointer: Result:='^'+GetTypeDesc(T.TypeEl as TPasType)+'='+BaseTypeNames[T.BaseType]; - else Result:=''; - end; + if T.IdentEl<>nil then + begin + // named element + if T.IdentEl=T.TypeEl then + Result:='type '+GetTypeDesc(T.TypeEl) + else + Result:=GetObjName(T.IdentEl)+':'+GetTypeDesc(T.TypeEl); + if T.ExprEl<>nil then + Result:=Result+':='+GetTreeDesc(T.ExprEl); + end + else if T.TypeEl<>nil then + begin + // anonymous constant expression with named type + Result:='const '+GetTreeDesc(T.ExprEl); + if T.ExprEl<>nil then + Result:=Result+':='+GetTreeDesc(T.ExprEl); + end + else + begin + // anonymous const expr without explicit type, e.g. 123.4 + Result:=Result+':='+GetTreeDesc(T.ExprEl); + end; + Result:=Result+'='+BaseTypeNames[T.BaseType]; end; -procedure SetResolvedType(out ResolvedType: TPasResolvedType; - Kind: TPasResolvedKind; BaseType: TResolveBaseType; IdentEl: TPasElement; - TypeEl: TPasType); +procedure SetResolverIdentifier(out ResolvedType: TPasResolverResult; + BaseType: TResolverBaseType; IdentEl: TPasElement; TypeEl: TPasType); begin - ResolvedType.Kind:=Kind; ResolvedType.BaseType:=BaseType; ResolvedType.IdentEl:=IdentEl; ResolvedType.TypeEl:=TypeEl; ResolvedType.ExprEl:=nil; end; -procedure SetResolvedTypeExpr(out ResolvedType: TPasResolvedType; - BaseType: TResolveBaseType; ExprEl: TPasExpr); +procedure SetResolverTypeExpr(out ResolvedType: TPasResolverResult; + BaseType: TResolverBaseType; TypeEl: TPasType; ExprEl: TPasExpr); begin - ResolvedType.Kind:=rkExpr; ResolvedType.BaseType:=BaseType; ResolvedType.IdentEl:=nil; - ResolvedType.TypeEl:=nil; + ResolvedType.TypeEl:=TypeEl; ResolvedType.ExprEl:=ExprEl; end; @@ -980,6 +1121,45 @@ begin Result:=false; end; +{ TPasWithExprScope } + +class function TPasWithExprScope.IsStoredInElement: boolean; +begin + Result:=false; +end; + +class function TPasWithExprScope.FreeOnPop: boolean; +begin + Result:=false; +end; + +procedure TPasWithExprScope.IterateElements(const aName: string; + StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; + Data: Pointer; var Abort: boolean); +begin + Scope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort); +end; + +procedure TPasWithExprScope.WriteIdentifiers(Prefix: string); +begin + writeln(Prefix+'WithExpr: '+GetTreeDesc(Expr,length(Prefix))); + Scope.WriteIdentifiers(Prefix); +end; + +{ TPasWithScope } + +constructor TPasWithScope.Create; +begin + inherited Create; + ExpressionScopes:=TObjectList.Create(true); +end; + +destructor TPasWithScope.Destroy; +begin + FreeAndNil(ExpressionScopes); + inherited Destroy; +end; + { TPasProcedureScope } function TPasProcedureScope.FindIdentifier(const Identifier: String @@ -992,13 +1172,20 @@ begin end; procedure TPasProcedureScope.IterateElements(const aName: string; - const OnIterateElement: TIterateScopeElement; Data: Pointer; - var Abort: boolean); + StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; + Data: Pointer; var Abort: boolean); begin - inherited IterateElements(aName, OnIterateElement, Data, Abort); + inherited IterateElements(aName, StartScope, OnIterateElement, Data, Abort); if Abort then exit; if ClassScope<>nil then - ClassScope.IterateElements(aName, OnIterateElement, Data, Abort); + ClassScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort); +end; + +procedure TPasProcedureScope.WriteIdentifiers(Prefix: string); +begin + inherited WriteIdentifiers(Prefix); + if ClassScope<>nil then + ClassScope.WriteIdentifiers(Prefix+' '); end; { TPasClassScope } @@ -1013,13 +1200,20 @@ begin end; procedure TPasClassScope.IterateElements(const aName: string; - const OnIterateElement: TIterateScopeElement; Data: Pointer; - var Abort: boolean); + StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; + Data: Pointer; var Abort: boolean); begin - inherited IterateElements(aName, OnIterateElement, Data, Abort); + inherited IterateElements(aName, StartScope, OnIterateElement, Data, Abort); if Abort then exit; if AncestorScope<>nil then - AncestorScope.IterateElements(aName,OnIterateElement,Data,Abort); + AncestorScope.IterateElements(aName,StartScope,OnIterateElement,Data,Abort); +end; + +procedure TPasClassScope.WriteIdentifiers(Prefix: string); +begin + inherited WriteIdentifiers(Prefix); + if AncestorScope<>nil then + AncestorScope.WriteIdentifiers(Prefix+' '); end; { TPasDotClassScope } @@ -1031,10 +1225,15 @@ begin end; procedure TPasDotClassScope.IterateElements(const aName: string; - const OnIterateElement: TIterateScopeElement; Data: Pointer; - var Abort: boolean); + StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; + Data: Pointer; var Abort: boolean); begin - ClassScope.IterateElements(aName, OnIterateElement, Data, Abort); + ClassScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort); +end; + +procedure TPasDotClassScope.WriteIdentifiers(Prefix: string); +begin + ClassScope.WriteIdentifiers(Prefix); end; { TPasDotRecordScope } @@ -1046,10 +1245,15 @@ begin end; procedure TPasDotRecordScope.IterateElements(const aName: string; - const OnIterateElement: TIterateScopeElement; Data: Pointer; - var Abort: boolean); + StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; + Data: Pointer; var Abort: boolean); begin - RecordScope.IterateElements(aName, OnIterateElement, Data, Abort); + RecordScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort); +end; + +procedure TPasDotRecordScope.WriteIdentifiers(Prefix: string); +begin + RecordScope.WriteIdentifiers(Prefix); end; { TPasIdentifier } @@ -1115,15 +1319,15 @@ end; { TPasSubModuleScope } -procedure TPasSubModuleScope.OnInternalIterate(El: TPasElement; - Scope: TPasScope; Data: Pointer; var Abort: boolean); +procedure TPasSubModuleScope.OnInternalIterate(El: TPasElement; ElScope, + StartScope: TPasScope; Data: Pointer; var Abort: boolean); var FilterData: PPasIterateFilterData absolute Data; begin if El.ClassType=TPasModule then exit; // skip used units // call the original iterator - FilterData^.OnIterate(El,Scope,FilterData^.Data,Abort); + FilterData^.OnIterate(El,ElScope,StartScope,FilterData^.Data,Abort); end; procedure TPasSubModuleScope.SetCurModule(AValue: TPasModule); @@ -1158,8 +1362,8 @@ begin end; procedure TPasSubModuleScope.IterateElements(const aName: string; - const OnIterateElement: TIterateScopeElement; Data: Pointer; - var Abort: boolean); + StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; + Data: Pointer; var Abort: boolean); var FilterData: TPasIterateFilterData; begin @@ -1167,11 +1371,19 @@ begin FilterData.Data:=Data; if ImplementationScope<>nil then begin - ImplementationScope.IterateElements(aName,@OnInternalIterate,@FilterData,Abort); + ImplementationScope.IterateElements(aName,StartScope,@OnInternalIterate,@FilterData,Abort); if Abort then exit; end; if InterfaceScope<>nil then - InterfaceScope.IterateElements(aName,@OnInternalIterate,@FilterData,Abort); + InterfaceScope.IterateElements(aName,StartScope,@OnInternalIterate,@FilterData,Abort); +end; + +procedure TPasSubModuleScope.WriteIdentifiers(Prefix: string); +begin + if ImplementationScope<>nil then + ImplementationScope.WriteIdentifiers(Prefix+' '); + if InterfaceScope<>nil then + InterfaceScope.WriteIdentifiers(Prefix+' '); end; { TPasSectionScope } @@ -1215,13 +1427,13 @@ begin end; procedure TPasSectionScope.IterateElements(const aName: string; - const OnIterateElement: TIterateScopeElement; Data: Pointer; - var Abort: boolean); + StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; + Data: Pointer; var Abort: boolean); var i: Integer; UsesScope: TPasIdentifierScope; begin - inherited IterateElements(aName, OnIterateElement, Data, Abort); + inherited IterateElements(aName, StartScope, OnIterateElement, Data, Abort); if Abort then exit; for i:=0 to UsesList.Count-1 do begin @@ -1229,19 +1441,32 @@ begin {$IFDEF VerbosePasResolver} writeln('TPasSectionScope.IterateElements "',aName,'" in used unit ',GetObjName(UsesScope.Element)); {$ENDIF} - UsesScope.IterateElements(aName,OnIterateElement,Data,Abort); + UsesScope.IterateElements(aName,StartScope,OnIterateElement,Data,Abort); if Abort then exit; end; end; +procedure TPasSectionScope.WriteIdentifiers(Prefix: string); +var + i: Integer; + UsesScope: TPasIdentifierScope; +begin + inherited WriteIdentifiers(Prefix); + for i:=0 to UsesList.Count-1 do + begin + UsesScope:=TPasIdentifierScope(UsesList[i]); + writeln(Prefix+'Uses: '+GetObjName(UsesScope.Element)); + end; +end; + { TPasModuleScope } procedure TPasModuleScope.IterateElements(const aName: string; - const OnIterateElement: TIterateScopeElement; Data: Pointer; - var Abort: boolean); + StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; + Data: Pointer; var Abort: boolean); begin if CompareText(aName,Element.Name)<>0 then exit; - OnIterateElement(Element,Self,Data,Abort); + OnIterateElement(Element,Self,StartScope,Data,Abort); end; { TPasDefaultScope } @@ -1271,6 +1496,8 @@ end; destructor TResolveData.Destroy; begin Element:=nil; + Owner:=nil; + Next:=nil; inherited Destroy; end; @@ -1281,11 +1508,17 @@ begin Result:=true; end; -procedure TPasScope.IterateElements(const aName: string; +class function TPasScope.FreeOnPop: boolean; +begin + Result:=not IsStoredInElement; +end; + +procedure TPasScope.IterateElements(const aName: string; StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; Data: Pointer; var Abort: boolean); begin if aName='' then ; + if StartScope=nil then ; if Data=nil then ; if OnIterateElement=nil then ; if Abort then ; @@ -1299,11 +1532,10 @@ end; { TPasResolver } // inline -function TPasResolver.PushScope(El: TPasElement; ScopeClass: TPasScopeClass - ): TPasScope; +function TPasResolver.GetBaseType(bt: TResolverBaseType + ): TPasUnresolvedSymbolRef; begin - Result:=CreateScope(El,ScopeClass); - PushScope(Result); + Result:=FBaseTypes[bt]; end; // inline @@ -1312,88 +1544,146 @@ begin Result:=FScopes[Index]; end; -procedure TPasResolver.OnFindFirstElement(El: TPasElement; Scope: TPasScope; - FindFirstElementData: Pointer; var Abort: boolean); +procedure TPasResolver.ClearResolveDataList(Kind: TResolveDataListKind); var - Data: PFindFirstElementData absolute FindFirstElementData; + El: TPasElement; + RData: TResolveData; +begin + // clear CustomData + while FLastCreatedData[Kind]<>nil do + begin + RData:=FLastCreatedData[Kind]; + El:=RData.Element; + El.CustomData:=nil; + FLastCreatedData[Kind]:=RData.Next; + RData.Free; + end; +end; + +procedure TPasResolver.OnFindFirstElement(El: TPasElement; ElScope, + StartScope: TPasScope; FindFirstElementData: Pointer; var Abort: boolean); +var + Data: PPRFindFirstData absolute FindFirstElementData; begin Data^.Found:=El; + Data^.ElScope:=ElScope; + Data^.StartScope:=StartScope; Abort:=true; - if Scope=nil then ; end; -procedure TPasResolver.OnFindCallProc(El: TPasElement; Scope: TPasScope; - FindProcsData: Pointer; var Abort: boolean); +procedure TPasResolver.OnFindCallProc(El: TPasElement; ElScope, + StartScope: TPasScope; FindProcsData: Pointer; var Abort: boolean); var Data: PFindCallProcData absolute FindProcsData; - Proc, OldProc: TPasProcedure; + Proc, PrevProc: TPasProcedure; Distance: integer; begin - if not (El is TPasProcedure) then - begin - // identifier is not a proc - Abort:=true; - if Data^.Found=nil then - begin - // ToDo: use the ( as error position - RaiseMsg(nSyntaxErrorExpectedButFound,sSyntaxErrorExpectedButFound,[';','('], - Data^.Params.Value); - end - else - exit; - end; - // identifier is a proc {$IFDEF VerbosePasResolver} - writeln('TPasResolver.OnFindCallProc ',GetTreeDesc(El,2)); + writeln('TPasResolver.OnFindCallProc START ---------'); {$ENDIF} - Proc:=TPasProcedure(El); - if Scope=nil 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 replace + if Data^.List<>nil then + begin + Data^.List.Remove(Data^.Found); + Data^.List.Add(Proc); + end; + Data^.Found:=Proc; + Data^.ElScope:=ElScope; + Data^.StartScope:=StartScope; + exit; + end; + end; + + if (Data^.Found=nil) or (Distancenil then - Data^.List.Add(Proc); + if El.CustomData.ClassType=TResElDataBuiltInProc then + begin + //TResElDataBuiltInProc(El.CustomData); + RaiseNotYetImplemented(20160927203131,El); + exit; + end; + end; + // identifier is not a proc + // ToDo: TypeCast + Abort:=true; + if Data^.Found=nil then + begin + // ToDo: use the ( as error position + RaiseMsg(nIllegalQualifier,sIllegalQualifier,['('],Data^.Params.Value); end; end; -procedure TPasResolver.OnFindOverloadProc(El: TPasElement; Scope: TPasScope; - FindOverloadData: Pointer; var Abort: boolean); +procedure TPasResolver.OnFindOverloadProc(El: TPasElement; ElScope, + StartScope: TPasScope; FindOverloadData: Pointer; var Abort: boolean); var Data: PFindOverloadProcData absolute FindOverloadData; Proc: TPasProcedure; @@ -1411,7 +1701,7 @@ begin exit; // found itself -> 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 + if (Data^.OnlyScope<>nil) and (Data^.OnlyScope<>ElScope) then begin // do not search any further, only one scope should be searched // for example when searching the method declaration of a method body @@ -1426,7 +1716,8 @@ begin if CheckOverloadProcCompatibility(Data^.Proc,Proc) then begin Data^.Found:=Proc; - Data^.FoundInScope:=Scope; + Data^.ElScope:=ElScope; + Data^.StartScope:=StartScope; Abort:=true; end; end; @@ -1439,15 +1730,15 @@ begin inherited SetCurrentParser(AValue); if CurrentParser<>nil then CurrentParser.Options:=CurrentParser.Options - +[po_resolvestandardtypes,po_nooverloadedprocs]; + +[po_resolvestandardtypes,po_nooverloadedprocs,po_keepclassforward]; end; procedure TPasResolver.CheckTopScope(ExpectedClass: TPasScopeClass); begin if TopScope=nil then - RaiseInternalError('Expected TopScope='+ExpectedClass.ClassName+' but found nil'); + RaiseInternalError(20160922163319,'Expected TopScope='+ExpectedClass.ClassName+' but found nil'); if TopScope.ClassType<>ExpectedClass then - RaiseInternalError('Expected TopScope='+ExpectedClass.ClassName+' but found '+TopScope.ClassName); + RaiseInternalError(20160922163323,'Expected TopScope='+ExpectedClass.ClassName+' but found '+TopScope.ClassName); end; function TPasResolver.AddIdentifier(Scope: TPasIdentifierScope; @@ -1490,7 +1781,7 @@ begin ResolveImplBlock(CurModule.InitializationSection); end else - RaiseInternalError(''); // unknown module + RaiseInternalError(20160922163327); // unknown module // check all methods have bodies for i:=0 to FPendingForwards.Count-1 do @@ -1527,7 +1818,7 @@ begin writeln('TPasResolver.FinishUsesList ',GetObjName(El)); {$ENDIF} if (El.ClassType=TProgramSection) then - RaiseInternalError('used unit is a program: '+GetObjName(El)); + RaiseInternalError(20160922163346,'used unit is a program: '+GetObjName(El)); // add unitname as identifier AddIdentifier(Scope,El.Name,El,pikSimple); @@ -1539,12 +1830,12 @@ begin else if (El.ClassType=TPasModule) then PublicEl:=TPasModule(El).InterfaceSection; if PublicEl=nil then - RaiseInternalError('uses element has no interface section: '+GetObjName(El)); + RaiseInternalError(20160922163352,'uses element has no interface section: '+GetObjName(El)); if PublicEl.CustomData=nil then - RaiseInternalError('uses element has no resolver data: ' + RaiseInternalError(20160922163358,'uses element has no resolver data: ' +El.Name+'->'+GetObjName(PublicEl)); if not (PublicEl.CustomData is TPasIdentifierScope) then - RaiseInternalError('uses element has invalid resolver data: ' + RaiseInternalError(20160922163403,'uses element has invalid resolver data: ' +El.Name+'->'+GetObjName(PublicEl)+'->'+PublicEl.CustomData.ClassName); UsesScope:=TPasIdentifierScope(PublicEl.CustomData); @@ -1684,7 +1975,7 @@ begin // finish non method, i.e. interface/implementation/nested procedure/method declaration if not IsValidIdent(ProcName) then - RaiseNotYetImplemented(El); + RaiseNotYetImplemented(20160922163407,El); if Proc.Parent is TPasClassType then begin @@ -1728,7 +2019,7 @@ begin ProcScope:=Proc.CustomData as TPasProcedureScope; ProcScope.DeclarationProc:=DeclProc; // remove DeclProc from scope - FoundInScope:=FindData.FoundInScope as TPasIdentifierScope; + FoundInScope:=FindData.ElScope as TPasIdentifierScope; FoundInScope.RemoveIdentifier(DeclProc); end else @@ -1739,7 +2030,7 @@ begin end; end else - RaiseNotYetImplemented(El.Parent); + RaiseNotYetImplemented(20160922163411,El.Parent); end; procedure TPasResolver.FinishMethodDeclHeader(Proc: TPasProcedure); @@ -1756,7 +2047,7 @@ begin FindData.Proc:=Proc; FindData.Args:=Proc.ProcType.Args; Abort:=false; - ClassScope.IterateElements(Proc.Name,@OnFindOverloadProc,@FindData,Abort); + ClassScope.IterateElements(Proc.Name,ClassScope,@OnFindOverloadProc,@FindData,Abort); if FindData.FoundNonProc<>nil then // proc hides a non proc -> duplicate RaiseMsg(nDuplicateIdentifier,sDuplicateIdentifier, @@ -1819,7 +2110,7 @@ begin if p<1 then begin if CurClassType=nil then - RaiseInternalError(''); + RaiseInternalError(20160922163415); break; end; aClassName:=LeftStr(ProcName,p-1); @@ -1828,10 +2119,10 @@ begin writeln('TPasResolver.FinishMethodBodyHeader searching class "',aClassName,'" ProcName="',ProcName,'" ...'); {$ENDIF} if not IsValidIdent(aClassName) then - RaiseNotYetImplemented(ImplProc.ProcType); + RaiseNotYetImplemented(20160922163417,ImplProc.ProcType); if CurClassType<>nil then - PushDotClassScope(CurClassType); + PushClassDotScope(CurClassType); CurClassType:=TPasClassType(FindFirstElement(aClassName,ImplProc.ProcType)); if not (CurClassType is TPasClassType) then @@ -1850,7 +2141,7 @@ begin {$ENDIF} // search ImplProc in class if not IsValidIdent(ProcName) then - RaiseNotYetImplemented(ImplProc.ProcType); + RaiseNotYetImplemented(20160922163421,ImplProc.ProcType); CurClassScope:=CurClassType.CustomData as TPasClassScope; FindData:=Default(TFindOverloadProcData); @@ -1858,7 +2149,7 @@ begin FindData.Args:=ImplProc.ProcType.Args; FindData.OnlyScope:=CurClassScope; Abort:=false; - CurClassScope.IterateElements(ProcName,@OnFindOverloadProc,@FindData,Abort); + CurClassScope.IterateElements(ProcName,CurClassScope,@OnFindOverloadProc,@FindData,Abort); if FindData.Found=nil then RaiseIdentifierNotFound(ImplProc.Name,ImplProc.ProcType); @@ -1924,21 +2215,12 @@ end; procedure TPasResolver.FinishExceptOnExpr; var El: TPasImplExceptOn; - Expr: TPrimitiveExpr; + ResolvedType: TPasResolverResult; begin CheckTopScope(TPasExceptOnScope); El:=TPasImplExceptOn(FTopScope.Element); - if El.VarExpr<>nil then - begin - if El.VarExpr.ClassType<>TPrimitiveExpr then - RaiseNotYetImplemented(El.VarExpr,'FinishExceptOnExpr'); - Expr:=TPrimitiveExpr(El.VarExpr); - if Expr.Kind<>pekIdent then - RaiseNotYetImplemented(Expr); - AddIdentifier(TPasExceptOnScope(FTopScope),Expr.Value,Expr,pikSimple); - end; - if El.TypeExpr<>nil then - ResolveExpr(El.TypeExpr); + ComputeElement(El.TypeEl,ResolvedType,[rcSkipTypeAlias]); + CheckIsClass(El.TypeEl,ResolvedType); end; procedure TPasResolver.FinishExceptOnStatement; @@ -1967,21 +2249,22 @@ var procedure GetPropType; var - AncProp: TPasIdentifier; + AncProp: TPasElement; begin if PropType<>nil then exit; if PropEl.VarType<>nil then PropType:=PropEl.VarType + // Note: a property with a type has no ancestor property 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 + AncProp:=ClassScope.AncestorScope.FindElement(PropEl.Name); + if (AncProp=nil) or (not (AncProp is TPasProperty)) then RaiseMsg(nNoPropertyFoundToOverride,sNoPropertyFoundToOverride,[],PropEl); - PropType:=TPasProperty(AncProp.Element).VarType; - CreateReference(AncProp.Element,PropEl); + PropType:=TPasProperty(AncProp).VarType; + CreateReference(AncProp,PropEl); end; end; @@ -2004,7 +2287,7 @@ var end; end else - RaiseNotYetImplemented(TBinaryExpr(Expr).left); + RaiseNotYetImplemented(20160922163430,TBinaryExpr(Expr).left); Expr:=TBinaryExpr(Expr).right end else if Expr.ClassType=TPrimitiveExpr then @@ -2016,10 +2299,10 @@ var exit; end else - RaiseNotYetImplemented(Expr); + RaiseNotYetImplemented(20160922163433,Expr); end else - RaiseNotYetImplemented(Expr); + RaiseNotYetImplemented(20160922163436,Expr); until false; end; @@ -2031,7 +2314,7 @@ begin if PropEl.IndexExpr<>nil then begin ResolveExpr(PropEl.IndexExpr); - RaiseNotYetImplemented(PropEl.IndexExpr); + RaiseNotYetImplemented(20160922163439,PropEl.IndexExpr); end; if PropEl.ReadAccessor<>nil then begin @@ -2167,6 +2450,8 @@ begin AncestorEl:=TPasClassType(FindFirstElement('TObject',aClass)); if not (AncestorEl is TPasClassType) then RaiseXExpectedButYFound('class type',GetObjName(AncestorEl),aClass); + if DirectAncestor=nil then + DirectAncestor:=AncestorEl; end; end else if AncestorType.ClassType<>TPasClassType then @@ -2224,10 +2509,7 @@ begin else if El.ClassType=TPasImplBeginBlock then ResolveImplBlock(TPasImplBeginBlock(El)) else if El.ClassType=TPasImplAssign then - begin - ResolveExpr(TPasImplAssign(El).left); - ResolveExpr(TPasImplAssign(El).right); - end + ResolveImplAssign(TPasImplAssign(El)) else if El.ClassType=TPasImplSimple then ResolveExpr(TPasImplSimple(El).expr) else if El.ClassType=TPasImplBlock then @@ -2235,17 +2517,17 @@ begin else if El.ClassType=TPasImplRepeatUntil then begin ResolveImplBlock(TPasImplBlock(El)); - ResolveExpr(TPasImplRepeatUntil(El).ConditionExpr); + ResolveBooleanExpr(TPasImplRepeatUntil(El).ConditionExpr); end else if El.ClassType=TPasImplIfElse then begin - ResolveExpr(TPasImplIfElse(El).ConditionExpr); + ResolveBooleanExpr(TPasImplIfElse(El).ConditionExpr); ResolveImplElement(TPasImplIfElse(El).IfBranch); ResolveImplElement(TPasImplIfElse(El).ElseBranch); end else if El.ClassType=TPasImplWhileDo then begin - ResolveExpr(TPasImplWhileDo(El).ConditionExpr); + ResolveBooleanExpr(TPasImplWhileDo(El).ConditionExpr); ResolveImplElement(TPasImplWhileDo(El).Body); end else if El.ClassType=TPasImplCaseOf then @@ -2263,18 +2545,17 @@ begin else if El.ClassType=TPasImplExceptOn then // handled in FinishExceptOnStatement else if El.ClassType=TPasImplRaise then - begin - ResolveExpr(TPasImplRaise(El).ExceptObject); - ResolveExpr(TPasImplRaise(El).ExceptAddr); - end + ResolveImplRaise(TPasImplRaise(El)) else if El.ClassType=TPasImplCommand then begin if TPasImplCommand(El).Command<>'' then - RaiseNotYetImplemented(El,'TPasResolver.ResolveImplElement'); + RaiseNotYetImplemented(20160922163442,El,'TPasResolver.ResolveImplElement'); end else if El.ClassType=TPasImplAsmStatement then + else if El.ClassType=TPasImplWithDo then + ResolveImplWithDo(TPasImplWithDo(El)) else - RaiseNotYetImplemented(El,'TPasResolver.ResolveImplElement'); + RaiseNotYetImplemented(20160922163445,El,'TPasResolver.ResolveImplElement'); end; procedure TPasResolver.ResolveImplCaseOf(CaseOf: TPasImplCaseOf); @@ -2300,7 +2581,7 @@ begin else if El.ClassType=TPasImplCaseElse then ResolveImplBlock(TPasImplCaseElse(El)) else - RaiseNotYetImplemented(El); + RaiseNotYetImplemented(20160922163448,El); end; // CaseOf.ElseBranch was already resolved via Elements end; @@ -2322,10 +2603,128 @@ begin ResolveImplElement(Loop.Body); end; +procedure TPasResolver.ResolveImplWithDo(El: TPasImplWithDo); +var + i, OldScopeCount: Integer; + Expr, ErrorEl: TPasExpr; + ExprResolved: TPasResolverResult; + TypeEl: TPasType; + WithScope: TPasWithScope; + WithExprScope: TPasWithExprScope; + ExprScope: TPasScope; +begin + OldScopeCount:=ScopeCount; + WithScope:=TPasWithScope(CreateScope(El,TPasWithScope)); + PushScope(WithScope); + for i:=0 to El.Expressions.Count-1 do + begin + Expr:=TPasExpr(El.Expressions[i]); + ResolveExpr(Expr); + ComputeElement(Expr,ExprResolved,[rcSkipTypeAlias]); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.ResolveImplWithDo ExprResolved=',GetResolverResultDesc(ExprResolved)); + {$ENDIF} + ErrorEl:=Expr; + // ToDo: use last element in Expr + TypeEl:=ExprResolved.TypeEl; + if TypeEl=nil then + RaiseMsg(nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot, + [BaseTypeNames[ExprResolved.BaseType]],ErrorEl); + if TypeEl.ClassType=TPasRecordType then + ExprScope:=TPasRecordType(TypeEl).CustomData as TPasRecordScope + else if TypeEl.ClassType=TPasClassType then + ExprScope:=TPasClassType(TypeEl).CustomData as TPasClassScope + else + RaiseMsg(nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot, + [TypeEl.ElementTypeName],ErrorEl); + WithExprScope:=TPasWithExprScope.Create; + WithExprScope.WithScope:=WithScope; + WithExprScope.Index:=i; + WithExprScope.Expr:=Expr; + WithExprScope.Scope:=ExprScope; + WithExprScope.NeedTmpVar:=not (ExprResolved.IdentEl is TPasType); + WithScope.ExpressionScopes.Add(WithExprScope); + PushScope(WithExprScope); + end; + ResolveImplElement(El.Body); + CheckTopScope(TPasWithExprScope); + if TopScope<>WithScope.ExpressionScopes[WithScope.ExpressionScopes.Count-1] then + RaiseInternalError(20160923102846); + while ScopeCount>OldScopeCount do + PopScope; +end; + +procedure TPasResolver.ResolveImplAssign(El: TPasImplAssign); +var + LeftResolved, RightResolved: TPasResolverResult; + Compatible: Integer; + Actual, Expected: String; +begin + ResolveExpr(El.left); + ResolveExpr(El.right); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.ResolveImplAssign Kind=',El.Kind,' left=',GetObjName(El.left),' right=',GetObjName(el.right)); + {$ENDIF} + // check LHS can be assigned + ComputeElement(El.left,LeftResolved,[rcSkipTypeAlias]); + CheckCanBeLHS(LeftResolved,true,El.left); + // compute RHS + ComputeElement(El.right,RightResolved,[rcSkipTypeAlias]); + case El.Kind of + akDefault: + begin + Compatible:=CheckAssignCompatibility(LeftResolved,RightResolved,El.right); + if Compatible=cIncompatible then + begin + Expected:=GetResolverResultDesc(LeftResolved); + Actual:=GetResolverResultDesc(RightResolved); + if LeftResolved.BaseType<>RightResolved.BaseType then + begin + Expected:=BaseTypeNames[LeftResolved.BaseType]; + Actual:=BaseTypeNames[RightResolved.BaseType]; + end + else if (LeftResolved.TypeEl<>nil) and (RightResolved.TypeEl<>nil) then + begin + if LeftResolved.TypeEl.ElementTypeName<>RightResolved.TypeEl.ElementTypeName then + begin + Expected:=LeftResolved.TypeEl.ElementTypeName; + Actual:=RightResolved.TypeEl.ElementTypeName; + end + else if LeftResolved.TypeEl.Name<>RightResolved.TypeEl.Name then + begin + Expected:=LeftResolved.TypeEl.Name; + Actual:=RightResolved.TypeEl.Name; + end; + end; + RaiseMsg(nIncompatibleTypeGotExpected,sIncompatibleTypeGotExpected, + [Actual,Expected],El.right); + end; + end; + else + RaiseNotYetImplemented(20160927143649,El,'AssignKind '+IntToStr(Ord(El.Kind))); + end; +end; + +procedure TPasResolver.ResolveImplRaise(El: TPasImplRaise); +var + ResolvedEl: TPasResolverResult; +begin + ResolveExpr(El.ExceptObject); + ResolveExpr(El.ExceptAddr); + ComputeElement(El.ExceptObject,ResolvedEl,[rcSkipTypeAlias]); + if (ResolvedEl.IdentEl=nil) then + RaiseMsg(nXExpectedButYFound,sXExpectedButYFound, + ['variable',ResolvedEl.TypeEl.ElementTypeName],El.ExceptObject); + if (ResolvedEl.IdentEl.ClassType<>TPasVariable) + and (ResolvedEl.IdentEl.ClassType<>TPasArgument) then + RaiseMsg(nXExpectedButYFound,sXExpectedButYFound, + ['variable',ResolvedEl.IdentEl.ElementTypeName],El.ExceptObject); + CheckIsClass(El.ExceptObject,ResolvedEl); +end; + procedure TPasResolver.ResolveExpr(El: TPasExpr); var Primitive: TPrimitiveExpr; - DeclEl: TPasElement; begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.ResolveExpr ',GetObjName(El)); @@ -2335,15 +2734,12 @@ begin begin Primitive:=TPrimitiveExpr(El); case Primitive.Kind of - pekIdent: - begin - DeclEl:=FindFirstElement(Primitive.Value,El); - //writeln('TPasResolver.ResolveExpr Ref=',GetObjName(El)+' Decl='+GetObjName(DeclEl)); - CreateReference(DeclEl,El); - end; - pekNumber,pekString,pekNil,pekBoolConst: exit; + pekIdent: ResolveNameExpr(El,Primitive.Value); + pekNumber: exit; + pekString: exit; + pekNil,pekBoolConst: exit; else - RaiseNotYetImplemented(El); + RaiseNotYetImplemented(20160922163451,El); end; end else if El.ClassType=TUnaryExpr then @@ -2355,15 +2751,53 @@ begin 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 + ResolveNameExpr(El,'Self') else if El.ClassType=TInheritedExpr then ResolveInherited(TInheritedExpr(El)) else - RaiseNotYetImplemented(El); + RaiseNotYetImplemented(20160922163453,El); +end; + +procedure TPasResolver.ResolveBooleanExpr(El: TPasExpr); +var + ResolvedCond: TPasResolverResult; +begin + ResolveExpr(El); + ComputeElement(El,ResolvedCond,[rcSkipTypeAlias]); + if ResolvedCond.BaseType<>btBoolean then + RaiseMsg(nXExpectedButYFound,sXExpectedButYFound, + [BaseTypeNames[btBoolean],BaseTypeNames[ResolvedCond.BaseType]],El); +end; + +procedure TPasResolver.ResolveNameExpr(El: TPasExpr; const aName: string); +var + FindData: TPRFindFirstData; + DeclEl: TPasElement; + Proc: TPasProcedure; +begin + DeclEl:=FindFirstElement(aName,FindData,El); + if DeclEl is TPasProcedure then + begin + // identifier is a call and args brackets are missing + if El.Parent.ClassType=TPasProperty then + // a property modifier -> ok + else + begin + Proc:=TPasProcedure(DeclEl); + if (Proc.ProcType.Args.Count>0) + and (TPasArgument(Proc.ProcType.Args[0]).ValueExpr=nil) + then + RaiseMsg(nWrongNumberOfParametersForCallTo, + sWrongNumberOfParametersForCallTo,[Proc.Name],El); + end; + end + else if DeclEl.ClassType=TPasUnresolvedSymbolRef then + begin + if DeclEl.CustomData is TResElDataBuiltInProc then + RaiseMsg(nWrongNumberOfParametersForCallTo, + sWrongNumberOfParametersForCallTo,[DeclEl.Name],El); + end; + CreateReference(DeclEl,El,@FindData); end; procedure TPasResolver.ResolveInherited(El: TInheritedExpr); @@ -2398,7 +2832,12 @@ begin DeclProcScope:=DeclProc.CustomData as TPasProcedureScope; AncestorProc:=DeclProcScope.OverriddenProc; if AncestorProc<>nil then - CreateReference(AncestorProc,El) + begin + CreateReference(AncestorProc,El); + if AncestorProc.IsAbstract then + RaiseMsg(nAbstractMethodsCannotBeCalledDirectly, + sAbstractMethodsCannotBeCalledDirectly,[],El); + end else begin // 'inherited;' without ancestor is ignored @@ -2414,10 +2853,12 @@ var ProcScope: TPasProcedureScope; AncestorScope: TPasClassScope; AncestorClass: TPasClassType; + InhScope: TPasDotClassScope; begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.ResolveInheritedCall El=',GetTreeDesc(El)); {$ENDIF} + CheckTopScope(TPasProcedureScope); ProcScope:=TPasProcedureScope(TopScope); if ProcScope.ClassScope=nil then @@ -2429,7 +2870,8 @@ begin // search call in ancestor AncestorClass:=TPasClassType(AncestorScope.Element); - PushDotClassScope(AncestorClass); + InhScope:=PushClassDotScope(AncestorClass); + InhScope.InheritedExpr:=true; ResolveExpr(El.right); PopScope; end; @@ -2451,7 +2893,7 @@ 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); + RaiseNotYetImplemented(20160922163456,El); end; end; eopAdd, @@ -2473,21 +2915,19 @@ begin eopGreaterThan, eopLessthanEqual, eopGreaterThanEqual, - eopIn, + //eopIn, eopIs, - eopAs, - eopSymmetricaldifference: + eopAs: + //eopSymmetricaldifference: begin - // ToDo: check if left operand supports operator ResolveExpr(El.right); - // ToDo: check if operator fits end; //eopAddress: ; //eopDeref: ; eopSubIdent: ResolveSubIdent(El); else - RaiseNotYetImplemented(El,OpcodeStrings[El.OpCode]); + RaiseNotYetImplemented(20160922163459,El,OpcodeStrings[El.OpCode]); end; end; @@ -2497,8 +2937,6 @@ var ModuleScope: TPasSubModuleScope; aModule: TPasModule; VarType: TPasType; - RecScope: TPasRecordScope; - SubScope: TPasSubScope; CurClassType: TPasClassType; begin //writeln('TPasResolver.ResolveSubIdent El.left=',GetObjName(El.left)); @@ -2548,32 +2986,12 @@ begin else if DeclEl.ClassType=TPasVariable then begin VarType:=TPasVariable(DeclEl).VarType; - if VarType.ClassType=TPasRecordType then - begin - RecScope:=TPasRecordType(VarType).CustomData as TPasRecordScope; - SubScope:=TPasDotRecordScope.Create; - SubScope.Owner:=Self; - 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} - writeln('TPasResolver.ResolveSubIdent DeclEl=',GetObjName(DeclEl),' VarType=',GetObjName(VarType)); - {$ENDIF} - end; - end; + if VarType=nil then + RaiseInternalError(20160922185910); + PushDotScopeForType(VarType,El); + ResolveExpr(El.right); + PopScope; + exit; end else begin @@ -2581,6 +2999,7 @@ begin writeln('TPasResolver.ResolveSubIdent DeclEl=',GetObjName(DeclEl)); {$ENDIF} end; + end; end else if El.left.ClassType=TSelfExpr then begin @@ -2590,7 +3009,7 @@ begin if DeclEl.ClassType=TPasClassType then begin CurClassType:=TPasClassType(DeclEl); - PushDotClassScope(CurClassType); + PushClassDotScope(CurClassType); ResolveExpr(El.right); PopScope; exit; @@ -2612,6 +3031,8 @@ var ProcName, Msg: String; FindData: TFindCallProcData; Abort: boolean; + El: TPasElement; + Ref: TResolvedReference; begin // first resolve params ResetSubScopes(ScopeDepth); @@ -2640,6 +3061,8 @@ begin if FindData.Count>1 then begin // multiple overloads fit => search again and list the candidates + FindData:=Default(TFindCallProcData); + FindData.Params:=Params; FindData.List:=TFPList.Create; try IterateElements(ProcName,@OnFindCallProc,@FindData,Abort); @@ -2647,8 +3070,12 @@ begin for i:=0 to FindData.List.Count-1 do begin // ToDo: create a hint for each candidate + El:=TPasElement(FindData.List[i]); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.ResolveParamsExpr Overload Candidate: ',GetElementSourcePosStr(El),' ',GetTreeDesc(El)); + {$ENDIF} Msg:=Msg+', '; - Msg:=Msg+GetElementSourcePosStr(TPasElement(FindData.List[i])); + Msg:=Msg+GetElementSourcePosStr(El); end; RaiseMsg(nCantDetermineWhichOverloadedFunctionToCall, sCantDetermineWhichOverloadedFunctionToCall+Msg,[ProcName],Params.Value); @@ -2656,11 +3083,29 @@ begin FindData.List.Free; end; end; - // found compatible proc - CreateReference(FindData.Found,Params.Value); + + // found compatible proc -> create reference + Ref:=CreateReference(FindData.Found,Params.Value); + if FindData.Found.IsVirtual or FindData.Found.IsOverride then + begin + if (TopScope.ClassType=TPasDotClassScope) + and TPasDotClassScope(TopScope).InheritedExpr then + begin + // call directly + if FindData.Found.IsAbstract then + RaiseMsg(nAbstractMethodsCannotBeCalledDirectly, + sAbstractMethodsCannotBeCalledDirectly,[],Params.Value); + end + else + begin + // call via method table + Ref.Flags:=Ref.Flags+[rrfVMT]; + end; + end + else end else - RaiseNotYetImplemented(Params,'with parameters'); + RaiseNotYetImplemented(20160922163501,Params,'with parameters'); end; procedure TPasResolver.CheckPendingForwards(El: TPasElement); @@ -2706,7 +3151,7 @@ end; procedure TPasResolver.AddModule(El: TPasModule); begin if TopScope<>DefaultScope then - RaiseInvalidScopeForElement(El); + RaiseInvalidScopeForElement(20160922163504,El); PushScope(El,TPasModuleScope); end; @@ -2726,7 +3171,7 @@ begin writeln('TPasResolver.AddType El=',GetObjName(El),' El.Parent=',GetObjName(El.Parent)); {$ENDIF} if not (TopScope is TPasIdentifierScope) then - RaiseInvalidScopeForElement(El); + RaiseInvalidScopeForElement(20160922163506,El); AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple); end; @@ -2736,7 +3181,7 @@ begin writeln('TPasResolver.AddRecordType ',GetObjName(El),' Parent=',GetObjName(El.Parent)); {$ENDIF} if not (TopScope is TPasIdentifierScope) then - RaiseInvalidScopeForElement(El); + RaiseInvalidScopeForElement(20160922163508,El); if El.Name<>'' then begin AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple); FPendingForwards.Add(El); // check forward declarations at the end @@ -2755,7 +3200,7 @@ begin writeln('TPasResolver.AddClassType ',GetObjName(El),' Parent=',GetObjName(El.Parent),' ',GetElementSourcePosStr(El)); {$ENDIF} if not (TopScope is TPasIdentifierScope) then - RaiseInvalidScopeForElement(El); + RaiseInvalidScopeForElement(20160922163510,El); Duplicate:=TPasIdentifierScope(TopScope).FindIdentifier(El.Name); //if Duplicate<>nil then @@ -2775,7 +3220,7 @@ begin writeln(' Resolving Forward=',GetObjName(ForwardDecl),' ',GetElementSourcePosStr(ForwardDecl)); {$ENDIF} if ForwardDecl.CustomData<>nil then - RaiseInternalError('forward class has already customdata'); + RaiseInternalError(20160922163513,'forward class has already customdata'); // create a ref from the forward to the real declaration CreateReference(El,ForwardDecl); // change the cache item @@ -2794,19 +3239,19 @@ begin writeln('TPasResolver.AddVariable ',GetObjName(El)); {$ENDIF} if not (TopScope is TPasIdentifierScope) then - RaiseInvalidScopeForElement(El); + RaiseInvalidScopeForElement(20160922163515,El); AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple); end; procedure TPasResolver.AddProperty(El: TPasProperty); begin if (El.Name='') then - RaiseNotYetImplemented(El); + RaiseNotYetImplemented(20160922163518,El); {$IFDEF VerbosePasResolver} writeln('TPasResolver.AddProperty ',GetObjName(El)); {$ENDIF} if not (TopScope is TPasClassScope) then - RaiseInvalidScopeForElement(El); + RaiseInvalidScopeForElement(20160922163520,El); AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple); end; @@ -2816,7 +3261,7 @@ begin writeln('TPasResolver.AddProcedure ',GetObjName(El)); {$ENDIF} if not (TopScope is TPasIdentifierScope) then - RaiseInvalidScopeForElement(El); + RaiseInvalidScopeForElement(20160922163522,El); AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikProc); PushScope(El,TPasProcedureScope); end; @@ -2824,19 +3269,19 @@ end; procedure TPasResolver.AddArgument(El: TPasArgument); begin if (El.Name='') then - RaiseInternalError(GetObjName(El)); + RaiseInternalError(20160922163526,GetObjName(El)); {$IFDEF VerbosePasResolver} writeln('TPasResolver.AddArgument ',GetObjName(El)); {$ENDIF} if not (TopScope is TPasProcedureScope) then - RaiseInvalidScopeForElement(El); + RaiseInvalidScopeForElement(20160922163529,El); AddIdentifier(TPasProcedureScope(TopScope),El.Name,El,pikSimple); end; procedure TPasResolver.AddFunctionResult(El: TPasResultElement); begin if TopScope.ClassType<>TPasProcedureScope then - RaiseInvalidScopeForElement(El); + RaiseInvalidScopeForElement(20160922163531,El); AddIdentifier(TPasProcedureScope(TopScope),ResolverResultVar,El,pikSimple); end; @@ -2866,6 +3311,233 @@ begin end; end; +procedure TPasResolver.ComputeBinaryExpr(Bin: TBinaryExpr; out + ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags); +var + LeftResolved, RightResolved: TPasResolverResult; +begin + ComputeElement(Bin.left,LeftResolved,Flags); + ComputeElement(Bin.right,RightResolved,Flags); + // ToDo: check operator overloading + if LeftResolved.BaseType in btAllInteger then + begin + if RightResolved.BaseType in (btAllInteger+btAllFloats) then + case Bin.OpCode of + eopAdd, eopSubtract, + eopMultiply, eopDiv, eopMod, + eopPower, + eopShl, eopShr, + eopAnd, eopOr, eopXor: + begin + SetResolverTypeExpr(ResolvedEl,LeftResolved.BaseType,LeftResolved.TypeEl,Bin); + exit; + end; + eopEqual, + eopNotEqual, + eopLessThan, + eopGreaterThan, + eopLessthanEqual, + eopGreaterThanEqual: + begin + SetResolverTypeExpr(ResolvedEl,btBoolean,nil,Bin); + exit; + end; + end; + end + else if LeftResolved.BaseType in btAllBooleans then + begin + if RightResolved.BaseType in btAllBooleans then + case Bin.OpCode of + eopAnd, eopOr, eopXor, + eopEqual, + eopNotEqual: + begin + SetResolverTypeExpr(ResolvedEl,btBoolean,nil,Bin); + exit; + end; + end; + end + else if LeftResolved.BaseType in btAllStrings then + begin + if RightResolved.BaseType in btAllStrings then + case Bin.OpCode of + eopAdd: + case LeftResolved.BaseType of + btChar: + begin + case RightResolved.BaseType of + btChar: SetResolverTypeExpr(ResolvedEl,btString,nil,Bin); + btWideChar: SetResolverTypeExpr(ResolvedEl,btUnicodeString,nil,Bin); + else SetResolverTypeExpr(ResolvedEl,RightResolved.BaseType,nil,Bin); + end; + exit; + end; + btWideChar: + begin + SetResolverTypeExpr(ResolvedEl,btUnicodeString,nil,Bin); + exit; + end; + btShortString: + begin + case RightResolved.BaseType of + btChar,btShortString,btWideChar: + SetResolverTypeExpr(ResolvedEl,btShortString,nil,Bin); + else + SetResolverTypeExpr(ResolvedEl,RightResolved.BaseType,nil,Bin); + end; + exit; + end; + btString,btAnsiString,btUnicodeString: + begin + SetResolverTypeExpr(ResolvedEl,LeftResolved.BaseType,nil,Bin); + exit; + end; + end; + eopEqual, + eopNotEqual, + eopLessThan, + eopGreaterThan, + eopLessthanEqual, + eopGreaterThanEqual: + begin + SetResolverTypeExpr(ResolvedEl,btBoolean,nil,Bin); + exit; + end; + end; + end + else if LeftResolved.BaseType in btAllFloats then + begin + if RightResolved.BaseType in (btAllInteger+btAllFloats) then + case Bin.OpCode of + eopAdd, eopSubtract, + eopMultiply, eopDivide, eopMod, + eopPower: + begin + SetResolverTypeExpr(ResolvedEl,LeftResolved.BaseType,LeftResolved.TypeEl,Bin); + exit; + end; + eopEqual, + eopNotEqual, + eopLessThan, + eopGreaterThan, + eopLessthanEqual, + eopGreaterThanEqual: + begin + SetResolverTypeExpr(ResolvedEl,btBoolean,nil,Bin); + exit; + end; + end; + end + else if LeftResolved.BaseType=btPointer then + begin + if RightResolved.BaseType in btAllInteger then + case Bin.OpCode of + eopAdd,eopSubtract: + begin + SetResolverTypeExpr(ResolvedEl,btPointer,LeftResolved.TypeEl,Bin); + exit; + end; + end + else if RightResolved.BaseType=btPointer then + case Bin.OpCode of + eopEqual, + eopNotEqual, + eopLessThan, + eopGreaterThan, + eopLessthanEqual, + eopGreaterThanEqual: + begin + SetResolverTypeExpr(ResolvedEl,btBoolean,nil,Bin); + exit; + end; + end; + end + else if LeftResolved.BaseType=btContext then + case Bin.OpCode of + eopEqual,eopNotEqual: + if RightResolved.BaseType=btNil then + begin + if (LeftResolved.TypeEl is TPasClassType) or (LeftResolved.TypeEl is TPasPointerType) then + begin + SetResolverTypeExpr(ResolvedEl,btBoolean,nil,Bin); + exit; + end; + end + else if (CheckSrcIsADstType(LeftResolved,RightResolved,Bin)<>cIncompatible) + or (CheckSrcIsADstType(RightResolved,LeftResolved,Bin)<>cIncompatible) then + begin + SetResolverTypeExpr(ResolvedEl,btBoolean,nil,Bin); + exit; + end; + eopIs: + if (RightResolved.TypeEl=nil) + or (RightResolved.IdentEl=nil) then + RaiseMsg(nXExpectedButYFound,sXExpectedButYFound, + ['class type',BaseTypeNames[RightResolved.BaseType]],Bin) + else if not (RightResolved.IdentEl is TPasType) then + RaiseMsg(nXExpectedButYFound,sXExpectedButYFound, + ['class type',RightResolved.IdentEl.ElementTypeName],Bin) + else if (CheckSrcIsADstType(RightResolved,LeftResolved,Bin)<>cIncompatible) then + begin + SetResolverTypeExpr(ResolvedEl,btBoolean,nil,Bin); + exit; + end + else + RaiseMsg(nTypesAreNotRelated,sTypesAreNotRelated,[],Bin); + eopAs: + if (CheckSrcIsADstType(RightResolved,LeftResolved,Bin)<>cIncompatible) then + begin + SetResolverTypeExpr(ResolvedEl,btContext,RightResolved.TypeEl,Bin); + exit; + end + else + RaiseMsg(nTypesAreNotRelated,sTypesAreNotRelated,[],Bin); + eopSubIdent: + begin + ResolvedEl:=RightResolved; + exit; + end; + end + else if LeftResolved.BaseType=btNil then + case Bin.OpCode of + eopEqual,eopNotEqual: + case RightResolved.BaseType of + btNil,btPointer: + begin + SetResolverTypeExpr(ResolvedEl,btBoolean,nil,Bin); + exit; + end; + btContext: + if (RightResolved.TypeEl is TPasClassType) + or (RightResolved.TypeEl is TPasPointerType) then + begin + SetResolverTypeExpr(ResolvedEl,btBoolean,nil,Bin); + exit; + end; + end; + end + else if LeftResolved.BaseType=btModule then + begin + if Bin.OpCode=eopSubIdent then + begin + ResolvedEl:=RightResolved; + exit; + end; + end; + RaiseMsg(nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[Bin.OpCode]],Bin); +end; + +procedure TPasResolver.CheckIsClass(El: TPasElement; + const ResolvedEl: TPasResolverResult); +begin + if (ResolvedEl.BaseType<>btContext) then + RaiseMsg(nXExpectedButYFound,sXExpectedButYFound, + ['class',BaseTypeNames[ResolvedEl.BaseType]],El); + if (ResolvedEl.TypeEl.ClassType<>TPasClassType) then + RaiseMsg(nXExpectedButYFound,sXExpectedButYFound, + ['class',ResolvedEl.TypeEl.ElementTypeName],El); +end; + constructor TPasResolver.Create; begin inherited Create; @@ -2910,10 +3582,10 @@ begin {$ENDIF} if (AParent=nil) and (FRootElement<>nil) and (AClass<>TPasUnresolvedTypeRef) then - RaiseInternalError('TPasResolver.CreateElement more than one root element Class="'+AClass.ClassName+'" Root='+GetObjName(FRootElement)); + RaiseInternalError(20160922163535,'more than one root element Class="'+AClass.ClassName+'" Root='+GetObjName(FRootElement)); if ASrcPos.FileName='' then - RaiseInternalError('TPasResolver.CreateElement missing filename'); + RaiseInternalError(20160922163541,'missing filename'); SrcY:=ASrcPos.Row; if StoreSrcColumns then begin @@ -2942,6 +3614,7 @@ begin AddArgument(TPasArgument(El)) else if AClass=TPasUnresolvedTypeRef then else if (AClass=TPasAliasType) + or (AClass=TPasArrayType) or (AClass=TPasProcedureType) or (AClass=TPasFunctionType) then AddType(TPasType(El)) @@ -2970,9 +3643,11 @@ begin or (AClass=TPasLibrary) then AddModule(TPasModule(El)) else if AClass.InheritsFrom(TPasExpr) then + // resolved when finished else if AClass.InheritsFrom(TPasImplBlock) then + // resolved finished else - RaiseNotYetImplemented(El,'CreateElement'); + RaiseNotYetImplemented(20160922163544,El); end; function TPasResolver.FindElement(const AName: String): TPasElement; @@ -2984,15 +3659,26 @@ end; function TPasResolver.FindFirstElement(const AName: String; ErrorPosEl: TPasElement): TPasElement; var - FindFirstData: TFindFirstElementData; + Data: TPRFindFirstData; +begin + Result:=FindFirstElement(AName,Data,ErrorPosEl); + if (Data.StartScope<>nil) and (Data.StartScope.ClassType=TPasWithExprScope) + and TPasWithExprScope(Data.StartScope).NeedTmpVar then + RaiseInternalError(20160923111727); // caller forgot to handle "With", use the other FindFirstElement instead +end; + +function TPasResolver.FindFirstElement(const AName: String; out + Data: TPRFindFirstData; ErrorPosEl: TPasElement): TPasElement; +var Abort: boolean; begin //writeln('TPasResolver.FindIdentifier Name="',AName,'"'); Result:=Nil; Abort:=false; - FindFirstData:=Default(TFindFirstElementData); - IterateElements(AName,@OnFindFirstElement,@FindFirstData,Abort); - Result:=FindFirstData.Found; + Data:=Default(TPRFindFirstData); + Data.ErrorPosEl:=ErrorPosEl; + IterateElements(AName,@OnFindFirstElement,@Data,Abort); + Result:=Data.Found; if Result<>nil then exit; RaiseIdentifierNotFound(AName,ErrorPosEl); end; @@ -3007,7 +3693,7 @@ begin for i:=FScopeCount-1 downto 0 do begin Scope:=Scopes[i]; - Scope.IterateElements(AName,OnIterateElement,Data,Abort); + Scope.IterateElements(AName,Scope,OnIterateElement,Data,Abort); if Abort then exit; if Scope is TPasSubScope then break; @@ -3065,34 +3751,51 @@ begin end; procedure TPasResolver.Clear; -var - Data: TResolveData; begin RestoreSubScopes(0); // clear stack, keep DefaultScope while (FScopeCount>0) and (FTopScope<>DefaultScope) do PopScope; - // clear CustomData - while FLastCreatedData<>nil do - begin - Data:=FLastCreatedData; - Data.Element.CustomData:=nil; - FLastCreatedData:=Data.Next; - Data.Free; - end; + ClearResolveDataList(lkModule); end; -procedure TPasResolver.AddObjFPCBuiltInIdentifiers(BaseTypes: TResolveBaseTypes - ); +procedure TPasResolver.ClearBuiltInIdentifiers; var - bt: TResolveBaseType; + bt: TResolverBaseType; +begin + ClearResolveDataList(lkBuiltIn); + for bt in TResolverBaseType do + FBaseTypes[bt]:=nil; +end; + +procedure TPasResolver.AddObjFPCBuiltInIdentifiers( + BaseTypes: TResolveBaseTypes; BaseProcs: TResolverBuiltInProcs); +var + bt: TResolverBaseType; begin for bt in BaseTypes do - AddIdentifier(FDefaultScope,BaseTypeNames[bt], - TPasUnresolvedSymbolRef.Create(BaseTypeNames[bt],nil),pikCustom); + AddBaseType(BaseTypeNames[bt],bt); + if bfLength in BaseProcs then + AddBuiltInProc('Length'); // ToDo + if bfSetLength in BaseProcs then + AddBuiltInProc('SetLength'); // ToDo end; -function TPasResolver.IsBaseType(aType: TPasType; BaseType: TResolveBaseType +function TPasResolver.AddBaseType(aName: shortstring; Typ: TResolverBaseType + ): TResElDataBaseType; +var + El: TPasUnresolvedSymbolRef; +begin + El:=TPasUnresolvedSymbolRef.Create(aName,nil); + if Typ<>btNone then + FBaseTypes[Typ]:=El; + Result:=TResElDataBaseType.Create; + Result.BaseType:=Typ; + AddResolveData(El,Result,lkBuiltIn); + FDefaultScope.AddIdentifier(aName,El,pikBaseType); +end; + +function TPasResolver.IsBaseType(aType: TPasType; BaseType: TResolverBaseType ): boolean; begin Result:=false; @@ -3101,8 +3804,28 @@ begin Result:=CompareText(aType.Name,BaseTypeNames[BaseType])=0; end; -function TPasResolver.CreateReference(DeclEl, RefEl: TPasElement - ): TResolvedReference; +function TPasResolver.AddBuiltInProc(aName: shortstring): TResElDataBuiltInProc; +var + El: TPasUnresolvedSymbolRef; +begin + El:=TPasUnresolvedSymbolRef.Create(aName,nil); + Result:=TResElDataBuiltInProc.Create; + AddResolveData(El,Result,lkBuiltIn); + FDefaultScope.AddIdentifier(aName,El,pikBuiltInProc); +end; + +procedure TPasResolver.AddResolveData(El: TPasElement; Data: TResolveData; + Kind: TResolveDataListKind); +begin + Data.Element:=El; + Data.Owner:=Self; + Data.Next:=FLastCreatedData[Kind]; + FLastCreatedData[Kind]:=Data; + El.CustomData:=Data; +end; + +function TPasResolver.CreateReference(DeclEl, RefEl: TPasElement; + FindData: PPRFindFirstData): TResolvedReference; procedure RaiseAlreadySet; var @@ -3117,7 +3840,7 @@ function TPasResolver.CreateReference(DeclEl, RefEl: TPasElement writeln(' TResolvedReference(RefEl.CustomData).Declaration=',GetObjName(FormerDeclEl), ' IsSame=',FormerDeclEl=DeclEl); end; - RaiseInternalError('TPasResolver.CreateReference customdata<>nil'); + RaiseInternalError(20160922163554,'customdata<>nil'); end; begin @@ -3127,29 +3850,36 @@ begin writeln('TPasResolver.CreateReference RefEl=',GetObjName(RefEl),' DeclEl=',GetObjName(DeclEl)); {$ENDIF} Result:=TResolvedReference.Create; - Result.Element:=RefEl; - Result.Owner:=Self; - Result.Next:=FLastCreatedData; + if FindData<>nil then + begin + if FindData^.StartScope.ClassType=TPasWithExprScope then + Result.WithExprScope:=TPasWithExprScope(FindData^.StartScope); + end; + AddResolveData(RefEl,Result,lkModule); Result.Declaration:=DeclEl; - FLastCreatedData:=Result; - RefEl.CustomData:=Result; end; function TPasResolver.CreateScope(El: TPasElement; ScopeClass: TPasScopeClass ): TPasScope; begin + if not ScopeClass.IsStoredInElement then + RaiseInternalError(20160923121858); if El.CustomData<>nil then - raise EPasResolve.Create('TPasResolver.CreateScope customdata<>nil'); + RaiseInternalError(20160923121849); {$IFDEF VerbosePasResolver} writeln('TPasResolver.CreateScope El=',GetObjName(El),' ScopeClass=',ScopeClass.ClassName); {$ENDIF} Result:=ScopeClass.Create; - Result.Element:=El; - Result.Owner:=Self; - Result.Next:=FLastCreatedData; - FLastCreatedData:=Result; - El.CustomData:=Result; + if Result.FreeOnPop then + begin + Result.Element:=El; + El.CustomData:=Result; + Result.Owner:=Self; + end + else + // add to free list + AddResolveData(El,Result,lkModule); end; procedure TPasResolver.PopScope; @@ -3157,21 +3887,21 @@ var Scope: TPasScope; begin if FScopeCount=0 then - RaiseInternalError('PopScope'); + RaiseInternalError(20160922163557); {$IFDEF VerbosePasResolver} //writeln('TPasResolver.PopScope ',FScopeCount,' ',FTopScope<>nil,' IsDefault=',FTopScope=FDefaultScope); - writeln('TPasResolver.PopScope ',FTopScope.ClassName,' IsStoredInElement=',FTopScope.IsStoredInElement,' Element=',GetObjName(FTopScope.Element)); + writeln('TPasResolver.PopScope ',FTopScope.ClassName,' IsStoredInElement=',FTopScope.IsStoredInElement,' Element=',GetObjName(FTopScope.Element),' FreeOnPop=',FTopScope.FreeOnPop); {$ENDIF} dec(FScopeCount); - if not FTopScope.IsStoredInElement then + if FTopScope.FreeOnPop then begin Scope:=FScopes[FScopeCount]; - if Scope.Element<>nil then + if (Scope.Element<>nil) and (Scope.Element.CustomData=Scope) then Scope.Element.CustomData:=nil; if Scope=FDefaultScope then FDefaultScope:=nil; - Scope.Free; FScopes[FScopeCount]:=nil; + Scope.Free; end; if FScopeCount>0 then FTopScope:=FScopes[FScopeCount-1] @@ -3182,18 +3912,25 @@ end; procedure TPasResolver.PushScope(Scope: TPasScope); begin if Scope=nil then - RaiseInternalError('TPasResolver.PushScope nil'); + RaiseInternalError(20160922163601); if length(FScopes)=FScopeCount then SetLength(FScopes,FScopeCount*2+10); FScopes[FScopeCount]:=Scope; inc(FScopeCount); FTopScope:=Scope; {$IFDEF VerbosePasResolver} - writeln('TPasResolver.PushScope ScopeCount=',ScopeCount,' ',GetObjName(FTopScope),' IsDefault=',FDefaultScope=FTopScope); + writeln('TPasResolver.PushScope ScopeCount=',ScopeCount,' ',GetObjName(FTopScope)); {$ENDIF} end; -function TPasResolver.PushDotClassScope(var CurClassType: TPasClassType +function TPasResolver.PushScope(El: TPasElement; ScopeClass: TPasScopeClass + ): TPasScope; +begin + Result:=CreateScope(El,ScopeClass); + PushScope(Result); +end; + +function TPasResolver.PushClassDotScope(var CurClassType: TPasClassType ): TPasDotClassScope; var ClassScope: TPasClassScope; @@ -3205,7 +3942,7 @@ begin CurClassType:=Ref.Declaration as TPasClassType; end; if CurClassType.CustomData=nil then - RaiseInternalError(''); + RaiseInternalError(20160922163611); ClassScope:=CurClassType.CustomData as TPasClassScope; Result:=TPasDotClassScope.Create; Result.Owner:=Self; @@ -3213,6 +3950,30 @@ begin PushScope(Result); end; +function TPasResolver.PushRecordDotScope(CurRecordType: TPasRecordType + ): TPasDotRecordScope; +var + RecScope: TPasRecordScope; +begin + RecScope:=TPasRecordType(CurRecordType).CustomData as TPasRecordScope; + Result:=TPasDotRecordScope.Create; + Result.Owner:=Self; + Result.RecordScope:=RecScope; + PushScope(Result); +end; + +function TPasResolver.PushDotScopeForType(TypeEl: TPasType; ErrorEl: TPasElement + ): TPasSubScope; +begin + if TypeEl.ClassType=TPasRecordType then + Result:=PushRecordDotScope(TPasRecordType(TypeEl)) + else if TypeEl.ClassType=TPasClassType then + Result:=PushClassDotScope(TPasClassType(TypeEl)) + else + RaiseMsg(nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot, + [TypeEl.ElementTypeName],ErrorEl); +end; + procedure TPasResolver.ResetSubScopes(out Depth: integer); // move all sub scopes from Scopes to SubScopes begin @@ -3288,28 +4049,29 @@ begin raise E; end; -procedure TPasResolver.RaiseNotYetImplemented(El: TPasElement; Msg: string); +procedure TPasResolver.RaiseNotYetImplemented(id: int64; El: TPasElement; + Msg: string); var s: String; begin - s:=sNotYetImplemented; + s:=sNotYetImplemented+' ['+IntToStr(id)+']'; if Msg<>'' then s:=s+' '+Msg; RaiseMsg(nNotYetImplemented,s,[GetObjName(El)],El); end; -procedure TPasResolver.RaiseInternalError(const Msg: string); +procedure TPasResolver.RaiseInternalError(id: int64; const Msg: string); begin - raise Exception.Create('Internal error: '+Msg); + raise Exception.Create('Internal error: ['+IntToStr(id)+'] '+Msg); end; -procedure TPasResolver.RaiseInvalidScopeForElement(El: TPasElement; +procedure TPasResolver.RaiseInvalidScopeForElement(id: int64; El: TPasElement; const Msg: string); var i: Integer; s: String; begin - s:='invalid scope for "'+GetObjName(El)+'": '; + s:='['+IntToStr(64)+'] invalid scope for "'+GetObjName(El)+'": '; for i:=0 to ScopeCount-1 do begin if i>0 then s:=s+','; @@ -3317,7 +4079,7 @@ begin end; if Msg<>'' then s:=s+': '+Msg; - RaiseInternalError(s); + RaiseInternalError(id,s); end; procedure TPasResolver.RaiseIdentifierNotFound(Identifier: string; @@ -3416,7 +4178,7 @@ function TPasResolver.CheckProcArgCompatibility(Proc1, Proc2: TPasProcedure; ArgNo: integer): boolean; var Arg1, Arg2: TPasArgument; - ArgType1, ArgType2: TPasResolvedType; + Arg1Resolved, Arg2Resolved: TPasResolverResult; begin Result:=false; Arg1:=TPasArgument(Proc1.ProcType.Args[ArgNo]); @@ -3430,47 +4192,182 @@ begin exit(Arg2.ArgType=nil); if Arg2.ArgType=nil then exit; - GetResolvedType(Arg1.ArgType,true,ArgType1); - GetResolvedType(Arg2.ArgType,true,ArgType2); + ComputeElement(Arg1,Arg1Resolved,[]); + ComputeElement(Arg2,Arg2Resolved,[]); - if (ArgType1.Kind<>ArgType2.Kind) - or (ArgType1.TypeEl=nil) - or (ArgType1.TypeEl<>ArgType2.TypeEl) then + if (Arg1Resolved.BaseType<>Arg2Resolved.BaseType) + or (Arg1Resolved.TypeEl=nil) + or (Arg1Resolved.TypeEl<>Arg2Resolved.TypeEl) then exit; // ToDo: check Arg1.ValueExpr Result:=true; end; +function TPasResolver.CheckCanBeLHS(const ResolvedEl: TPasResolverResult; + ErrorOnFalse: boolean; ErrorEl: TPasElement): boolean; +var + El: TPasElement; +begin + Result:=false; + El:=ResolvedEl.IdentEl; + if El=nil then exit; + if (El.ClassType=TPasVariable) + or (El.ClassType=TPasResultElement) then + exit(true) + else if (El.ClassType=TPasConst) then + begin + if (TPasConst(El).VarType<>nil) then + exit(true); // typed const are writable + end + else if El.ClassType=TPasProperty then + begin + if GetPasPropertySetter(TPasProperty(El))<>nil then + exit(true); + if ErrorOnFalse then + RaiseMsg(nPropertyNotWritable,sPropertyNotWritable,[],ErrorEl); + end + else if El is TPasArgument then + begin + if TPasArgument(El).Access in [argDefault, argVar, argOut] then exit(true); + end; + if ErrorOnFalse then + RaiseMsg(nVariableIdentifierExpected,sVariableIdentifierExpected,[],ErrorEl); +end; + +function TPasResolver.CheckAssignCompatibility(const LHS, + RHS: TPasResolverResult; ErrorEl: TPasElement): integer; +begin + // check if the RHS can be converted to LHS + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.CheckAssignCompatibility '); + {$ENDIF} + if LHS.TypeEl=nil then + begin + // ToDo: untyped parameter + RaiseNotYetImplemented(20160922163631,LHS.IdentEl); + end + else if LHS.BaseType=RHS.BaseType then + begin + if LHS.BaseType=btContext then + exit(CheckCustomTypeCompatibility(RHS,LHS,ErrorEl)) + else + exit(cExact); // same base type, maybe not same type name (e.g. longint and integer) + end + else if (LHS.BaseType in btAllInteger) + and (RHS.BaseType in btAllInteger) then + exit(cExact+1) // ToDo: range check for Expr + else if (LHS.BaseType in btAllBooleans) + and (RHS.BaseType in btAllBooleans) then + exit(cExact+1) + else if (LHS.BaseType in btAllStrings) + and (RHS.BaseType in btAllStrings) then + exit(cExact+1) // ToDo: check Expr if Param=btChar/btWideChar + else if (LHS.BaseType in btAllFloats) + and (RHS.BaseType in btAllFloats) then + exit(cExact+1) + else if RHS.BaseType=btNil then + begin + if LHS.BaseType=btPointer then + exit(cExact) + else if LHS.BaseType=btContext then + begin + if (LHS.TypeEl is TPasClassType) + or (LHS.TypeEl is TPasPointerType) then + exit(cExact); + end + else + exit(cIncompatible); + end + else + exit(cIncompatible); + RaiseNotYetImplemented(20160922163634,ErrorEl,'LHS='+GetResolverResultDesc(LHS)+' RHS='+GetResolverResultDesc(RHS)); +end; + +function TPasResolver.GetPasPropertyType(El: TPasProperty): TPasType; +begin + Result:=nil; + while El<>nil do + begin + if El.VarType<>nil then + exit(El.VarType); + El:=GetPasPropertyAncestor(El); + end; +end; + +function TPasResolver.GetPasPropertyAncestor(El: TPasProperty): TPasProperty; +begin + Result:=nil; + if El=nil then exit; + if El.VarType<>nil then exit; // a a property with a type has no ancestor + if El.CustomData=nil then exit; + Result:=TPasProperty(TResolvedReference(El.CustomData).Declaration); +end; + +function TPasResolver.GetPasPropertyGetter(El: TPasProperty): TPasElement; +// search the member variable or getter function of a property +var + DeclEl: TPasElement; +begin + Result:=nil; + while El<>nil do + begin + if El.ReadAccessor<>nil then + begin + DeclEl:=(El.ReadAccessor.CustomData as TResolvedReference).Declaration; + Result:=DeclEl; + exit; + end; + El:=GetPasPropertyAncestor(El); + end; +end; + +function TPasResolver.GetPasPropertySetter(El: TPasProperty): TPasElement; +// search the member variable or setter procedure of a property +var + DeclEl: TPasElement; +begin + Result:=nil; + while El<>nil do + begin + if El.WriteAccessor<>nil then + begin + DeclEl:=(El.WriteAccessor.CustomData as TResolvedReference).Declaration; + Result:=DeclEl; + exit; + end; + El:=GetPasPropertyAncestor(El); + end; +end; + function TPasResolver.CheckParamCompatibility(Expr: TPasExpr; Param: TPasArgument; ParamNo: integer; RaiseOnError: boolean): integer; var - ExprType, ParamType: TPasResolvedType; + ExprResolved, ParamResolved: TPasResolverResult; function ExprCanBeVarParam: boolean; begin Result:=false; - if (ExprType.Kind<>rkIdentifier) then exit; - if ExprType.IdentEl=nil then exit; - if ExprType.IdentEl.ClassType=TPasVariable then exit(true); - if (ExprType.IdentEl.ClassType=TPasConst) - and (TPasConst(ExprType.IdentEl).VarType<>nil) then + if ExprResolved.IdentEl=nil then exit; + if ExprResolved.IdentEl.ClassType=TPasVariable then exit(true); + if (ExprResolved.IdentEl.ClassType=TPasConst) + and (TPasConst(ExprResolved.IdentEl).VarType<>nil) then exit(true); // typed const are writable end; var MustFitExactly: Boolean; + ComputeFlags: TPasResolverComputeFlags; begin Result:=cIncompatible; + ComputeFlags:=[]; MustFitExactly:=Param.Access in [argVar, argOut]; - GetResolvedType(Expr,not MustFitExactly,ExprType); + ComputeElement(Expr,ExprResolved,ComputeFlags); {$IFDEF VerbosePasResolver} - writeln('TPasResolver.CheckParamCompatibility Expr=',GetTreeDesc(Expr,2),' ResolvedExpr=',GetResolvedTypeDesc(ExprType)); + writeln('TPasResolver.CheckParamCompatibility Expr=',GetTreeDesc(Expr,2),' ResolvedExpr=',GetResolverResultDesc(ExprResolved)); {$ENDIF} - if ExprType.Kind=rkNone then - RaiseInternalError('GetResolvedType returned rkNone for '+GetTreeDesc(Expr)); if MustFitExactly then begin @@ -3483,114 +4380,65 @@ begin end; end; - GetResolvedType(Param,not MustFitExactly,ParamType); + ComputeElement(Param,ParamResolved,ComputeFlags); {$IFDEF VerbosePasResolver} - writeln('TPasResolver.CheckParamCompatibility Param=',GetTreeDesc(Param,2),' ResolvedParam=',GetResolvedTypeDesc(ParamType)); + writeln('TPasResolver.CheckParamCompatibility Param=',GetTreeDesc(Param,2),' ResolvedParam=',GetResolverResultDesc(ParamResolved)); {$ENDIF} - if ExprType.Kind=rkNone then - RaiseInternalError('GetResolvedType returned rkNone for '+GetTreeDesc(Param)); - if (ParamType.TypeEl=nil) and (Param.ArgType<>nil) then - RaiseInternalError('GetResolvedType returned TypeEl=nil for '+GetTreeDesc(Param)); + if (ParamResolved.TypeEl=nil) and (Param.ArgType<>nil) then + RaiseInternalError(20160922163628,'GetResolvedType returned TypeEl=nil for '+GetTreeDesc(Param)); if MustFitExactly then begin - if (ParamType.Kind=ExprType.Kind) - //or (ParamType.BaseType=ExprType.BaseType) - then + if (ParamResolved.BaseType=ExprResolved.BaseType) then begin - if (ParamType.TypeEl<>nil) and (ParamType.TypeEl=ExprType.TypeEl) then + if (ParamResolved.TypeEl<>nil) and (ParamResolved.TypeEl=ExprResolved.TypeEl) then exit(cExact); end; if RaiseOnError then RaiseMsg(nIncompatibleTypeArgNoVarParamMustMatchExactly, sIncompatibleTypeArgNoVarParamMustMatchExactly, - [ParamNo,GetTypeDesc(ExprType.TypeEl),GetTypeDesc(ParamType.TypeEl)], + [ParamNo,GetTypeDesc(ExprResolved.TypeEl),GetTypeDesc(ParamResolved.TypeEl)], Expr); exit(cIncompatible); end; - // check if the Expr can be converted to Param - {$IFDEF VerbosePasResolver} - writeln('TPasResolver.CheckParamCompatibility '); - {$ENDIF} - case ParamType.Kind of - rkIdentifier, - rkExpr: - if ExprType.Kind in [rkExpr,rkIdentifier] then - begin - if ParamType.TypeEl=nil then - begin - // ToDo: untyped parameter - RaiseNotYetImplemented(Param); - end - else if ParamType.BaseType=ExprType.BaseType then - begin - 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(cExact+1) // ToDo: range check for Expr - else if (ParamType.BaseType in btAllBooleans) - and (ExprType.BaseType in btAllBooleans) then - exit(cExact+1) - else if (ParamType.BaseType in btAllStrings) - and (ExprType.BaseType in btAllStrings) then - exit(cExact+1) // ToDo: check Expr if Param=btChar/btWideChar - else if (ParamType.BaseType in btAllFloats) - and (ExprType.BaseType in btAllFloats) then - exit(cExact+1) - else if ExprType.BaseType=btNil then - begin - if ParamType.BaseType=btPointer then - exit(cExact); - // ToDo: allow classes and custom pointers - end - else - exit(cIncompatible); - end; - //rkArrayOf: ; - //rkPointer: ; - else - end; - - RaiseNotYetImplemented(Expr,':TPasResolver.CheckParamCompatibility: Param='+GetResolvedTypeDesc(ParamType)+' '+GetResolvedTypeDesc(ExprType)); + Result:=CheckAssignCompatibility(ParamResolved,ExprResolved,Expr); end; function TPasResolver.CheckCustomTypeCompatibility(const SrcType, - DestType: TPasResolvedType; ErrorEl: TPasElement): integer; + DestType: TPasResolverResult; ErrorEl: TPasElement): integer; var SrcTypeEl, DstTypeEl: TPasType; begin if (SrcType.TypeEl=nil) then - RaiseInternalError(''); + RaiseInternalError(20160922163645); if (DestType.TypeEl=nil) then - RaiseInternalError(''); + RaiseInternalError(20160922163648); SrcTypeEl:=SrcType.TypeEl; DstTypeEl:=DestType.TypeEl; + {$IFDEF VerbosePasResolver} + //writeln('TPasResolver.CheckCustomTypeCompatibility SrcTypeEl=',GetObjName(SrcTypeEl),' DstTypeEl=',GetObjName(DstTypeEl)); + {$ENDIF} if SrcTypeEl.ClassType=TPasClassType then begin if DstTypeEl.ClassType=TPasClassType then exit(CheckSrcIsADstType(SrcType,DestType,ErrorEl)) else - RaiseNotYetImplemented(ErrorEl); + RaiseNotYetImplemented(20160922163652,ErrorEl); end else - RaiseNotYetImplemented(ErrorEl); + RaiseNotYetImplemented(20160922163654,ErrorEl); end; -procedure TPasResolver.GetResolvedType(El: TPasElement; SkipTypeAlias: boolean; out - ResolvedType: TPasResolvedType); +procedure TPasResolver.ComputeElement(El: TPasElement; out + ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags); var - bt: TResolveBaseType; DeclEl: TPasElement; begin - ResolvedType:=Default(TPasResolvedType); + ResolvedEl:=Default(TPasResolverResult); {$IFDEF VerbosePasResolver} - writeln('TPasResolver.GetResolvedType El=',GetObjName(El),' SkipTypeAlias=',SkipTypeAlias); + writeln('TPasResolver.ComputeElement El=',GetObjName(El),' SkipTypeAlias=',rcSkipTypeAlias in Flags); {$ENDIF} if El=nil then exit; @@ -3600,81 +4448,75 @@ begin pekIdent,pekSelf: begin if El.CustomData is TResolvedReference then - GetResolvedType(TResolvedReference(El.CustomData).Declaration,SkipTypeAlias,ResolvedType) + ComputeElement(TResolvedReference(El.CustomData).Declaration,ResolvedEl,Flags) else - RaiseNotYetImplemented(El,': cannot resolve this'); + RaiseNotYetImplemented(20160922163658,El); end; pekNumber: - // ToDo: check if btByte, btSmallInt, ... - SetResolvedTypeExpr(ResolvedType,btLongint,TPrimitiveExpr(El)); + // ToDo: check if btByte, btSmallInt, btSingle, ... + if Pos('.',TPrimitiveExpr(El).Value)>0 then + SetResolverTypeExpr(ResolvedEl,btDouble,FBaseTypes[btDouble],TPrimitiveExpr(El)) + else + SetResolverTypeExpr(ResolvedEl,btLongint,FBaseTypes[btLongint],TPrimitiveExpr(El)); pekString: - SetResolvedTypeExpr(ResolvedType,btString,TPrimitiveExpr(El)); - //pekSet: + SetResolverTypeExpr(ResolvedEl,btString,FBaseTypes[btString],TPrimitiveExpr(El)); pekNil: - SetResolvedTypeExpr(ResolvedType,btNil,TPrimitiveExpr(El)); + SetResolverTypeExpr(ResolvedEl,btNil,FBaseTypes[btNil],TPrimitiveExpr(El)); pekBoolConst: - SetResolvedTypeExpr(ResolvedType,btBoolean,TPrimitiveExpr(El)); - //pekRange: - //pekUnary: - //pekBinary: - //pekFuncParams: - //pekArrayParams: - //pekListOfExp: - //pekInherited: + SetResolverTypeExpr(ResolvedEl,btBoolean,FBaseTypes[btBoolean],TPrimitiveExpr(El)); else - RaiseNotYetImplemented(El,': cannot resolve this'); + RaiseNotYetImplemented(20160922163701,El); end; end else if El.ClassType=TPasUnresolvedSymbolRef then begin // built-in type - for bt in TResolveBaseType do - if CompareText(BaseTypeNames[bt],El.Name)=0 then - begin - SetResolvedType(ResolvedType,rkIdentifier,bt,nil,TPasUnresolvedSymbolRef(El)); - break; - end; + if El.CustomData is TResElDataBaseType then + SetResolverTypeExpr(ResolvedEl,TResElDataBaseType(El.CustomData).BaseType, + TPasUnresolvedSymbolRef(El),nil) + else + RaiseNotYetImplemented(20160926194756,El); end + else if El.ClassType=TBinaryExpr then + ComputeBinaryExpr(TBinaryExpr(El),ResolvedEl,Flags) else if El.ClassType=TPasAliasType then begin - // e.f. 'var a: b' -> resolve b - GetResolvedType(TPasTypeAliasType(El).DestType,true,ResolvedType); - ResolvedType.IdentEl:=El; + // e.g. 'var a: b' -> compute b + ComputeElement(TPasAliasType(El).DestType,ResolvedEl,Flags); + ResolvedEl.IdentEl:=El; end else if (El.ClassType=TPasTypeAliasType) then begin - // e.g. 'type a = type b;' -> resolve b - if SkipTypeAlias then + // e.g. 'type a = type b;' -> compute b + if rcSkipTypeAlias in Flags 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; + ComputeElement(TPasTypeAliasType(El).DestType,ResolvedEl,Flags); + ResolvedEl.IdentEl:=El; end else - SetResolvedType(ResolvedType,rkIdentifier,btContext,El,TPasAliasType(El)); + SetResolverIdentifier(ResolvedEl,btContext,El,TPasAliasType(El)); end - else if (El.ClassType=TPasVariable) or (El.ClassType=TPasConst) - or (El.ClassType=TPasProperty) then + else if (El.ClassType=TPasVariable) or (El.ClassType=TPasConst) then begin - // e.g. 'var a:b' -> resolve b, use a as IdentEl - GetResolvedType(TPasVariable(El).VarType,SkipTypeAlias,ResolvedType); - ResolvedType.IdentEl:=El; + // e.g. 'var a:b' -> compute b, use a as IdentEl + ComputeElement(TPasVariable(El).VarType,ResolvedEl,Flags); + ResolvedEl.IdentEl:=El; + end + else if (El.ClassType=TPasProperty) then + begin + ComputeElement(GetPasPropertyType(TPasProperty(El)),ResolvedEl,Flags); + ResolvedEl.IdentEl:=El; end else if El.ClassType=TPasArgument then begin if TPasArgument(El).ArgType=nil then // untyped parameter - SetResolvedType(ResolvedType,rkIdentifier,btUntyped,El,nil) + SetResolverIdentifier(ResolvedEl,btUntyped,El,nil) else begin - // typed parameter -> use param as IdentEl, resolve type - GetResolvedType(TPasArgument(El).ArgType,SkipTypeAlias,ResolvedType); - ResolvedType.IdentEl:=El; + // typed parameter -> use param as IdentEl, compute type + ComputeElement(TPasArgument(El).ArgType,ResolvedEl,Flags); + ResolvedEl.IdentEl:=El; end; end else if El.ClassType=TPasClassType then @@ -3682,15 +4524,53 @@ begin if TPasClassType(El).IsForward then begin DeclEl:=(TPasClassType(El).CustomData as TResolvedReference).Declaration; - ResolvedType.TypeEl:=DeclEl as TPasClassType; + ResolvedEl.TypeEl:=DeclEl as TPasClassType; end else - ResolvedType.TypeEl:=TPasClassType(El); - SetResolvedType(ResolvedType,rkIdentifier,btContext, - ResolvedType.TypeEl,ResolvedType.TypeEl); + ResolvedEl.TypeEl:=TPasClassType(El); + SetResolverIdentifier(ResolvedEl,btContext, + ResolvedEl.TypeEl,ResolvedEl.TypeEl); end + else if El.ClassType=TPasRecordType then + SetResolverIdentifier(ResolvedEl,btContext,El,TPasRecordType(El)) + else if El.ClassType=TUnaryExpr then + begin + ComputeElement(TUnaryExpr(El).Operand,ResolvedEl,Flags); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.ComputeElement Unary Kind=',TUnaryExpr(El).Kind,' OpCode=',TUnaryExpr(El).OpCode,' OperandResolved=',GetResolverResultDesc(ResolvedEl)); + {$ENDIF} + case TUnaryExpr(El).OpCode of + eopAdd, eopSubtract: + if ResolvedEl.BaseType in btAllInteger then + exit + else + RaiseMsg(nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El); + eopNot: + if ResolvedEl.BaseType in (btAllInteger+btAllBooleans) then + exit + else + RaiseMsg(nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El); + end; + RaiseNotYetImplemented(20160926142426,El); + end + else if El.ClassType=TPasResultElement then + begin + ComputeElement(TPasResultElement(El).ResultType,ResolvedEl,Flags); + ResolvedEl.IdentEl:=El; + end + else if El is TPasModule then + SetResolverIdentifier(ResolvedEl,btModule,El,nil) + else if El is TNilExpr then + SetResolverTypeExpr(ResolvedEl,btNil,FBaseTypes[btNil],TNilExpr(El)) + else if El is TSelfExpr then + begin + ComputeElement(TResolvedReference(El.CustomData).Declaration,ResolvedEl,Flags); + ResolvedEl.IdentEl:=El; + end + else if El is TBoolConstExpr then + SetResolverTypeExpr(ResolvedEl,btBoolean,FBaseTypes[btBoolean],TBoolConstExpr(El)) else - RaiseNotYetImplemented(El,': cannot resolve this'); + RaiseNotYetImplemented(20160922163705,El); end; function TPasResolver.GetPasClassAncestor(ClassEl: TPasClassType; @@ -3727,7 +4607,7 @@ begin end; function TPasResolver.CheckSrcIsADstType(const ResolvedSrcType, - ResolvedDestType: TPasResolvedType; ErrorEl: TPasElement): integer; + ResolvedDestType: TPasResolverResult; ErrorEl: TPasElement): integer; // finds distance between classes SrcType and DestType var SrcEl, DstEl: TPasElement; @@ -3770,6 +4650,7 @@ begin begin // class ancestor -> increase distance SrcEl:=(ClassEl.CustomData as TPasClassScope).DirectAncestor; + writeln('TPasResolver.CheckSrcIsADstType AAA1 SrcEl=',GetObjName(SrcEl)); inc(Result); end; end @@ -3782,6 +4663,16 @@ end; { TPasIdentifierScope } +// inline +function TPasIdentifierScope.InternalFindIdentifier(const Identifier: String + ): TPasIdentifier; +var + LoName: String; +begin + LoName:=lowercase(Identifier); + Result:=TPasIdentifier(FItems.Find(LoName)); +end; + procedure TPasIdentifierScope.OnClearItem(Item, Dummy: pointer); var PasIdentifier: TPasIdentifier absolute Item; @@ -3818,16 +4709,31 @@ var begin LoName:=lowercase(Item.Identifier); Index:=FItems.FindIndexOf(LoName); + {$IFDEF VerbosePasResolver} + if Item.Owner<>nil then + raise Exception.Create('20160925184110'); + Item.Owner:=Self; + {$ENDIF} //writeln(' Index=',Index); if Index>=0 then begin // insert LIFO - last in, first out OldItem:=TPasIdentifier(FItems.List^[Index].Data); + {$IFDEF VerbosePasResolver} + if lowercase(OldItem.Identifier)<>LoName then + raise Exception.Create('20160925183438'); + {$ENDIF} Item.NextSameIdentifier:=OldItem; FItems.List^[Index].Data:=Item; end else + begin FItems.Add(LoName, Item); + {$IFDEF VerbosePasResolver} + if FindIdentifier(Item.Identifier)<>Item then + raise Exception.Create('20160925183849'); + {$ENDIF} + end; end; constructor TPasIdentifierScope.Create; @@ -3845,46 +4751,55 @@ end; function TPasIdentifierScope.FindIdentifier(const Identifier: String ): TPasIdentifier; -var - LoName: ShortString; begin - LoName:=lowercase(Identifier); - Result:=TPasIdentifier(FItems.Find(LoName)); + Result:=InternalFindIdentifier(Identifier); + {$IFDEF VerbosePasResolver} + if (Result<>nil) and (Result.Owner<>Self) then + begin + writeln('TPasIdentifierScope.FindIdentifier Result.Owner<>Self Owner='+GetObjName(Result.Owner)); + raise Exception.Create('20160925184159 '); + end; + {$ENDIF} end; function TPasIdentifierScope.RemoveIdentifier(El: TPasElement): boolean; var + Identifier, PrevIdentifier: TPasIdentifier; LoName: ShortString; - Identifier, LastIdentifier: TPasIdentifier; begin LoName:=lowercase(El.Name); Identifier:=TPasIdentifier(FItems.Find(LoName)); - LastIdentifier:=nil; + InternalFindIdentifier(El.Name); + PrevIdentifier:=nil; Result:=false; while Identifier<>nil do begin + {$IFDEF VerbosePasResolver} + if (Identifier.Owner<>Self) then + raise Exception.Create('20160925184159'); + {$ENDIF} if Identifier.Element=El then begin - if LastIdentifier<>nil then + if PrevIdentifier<>nil then begin - LastIdentifier.NextSameIdentifier:=Identifier.NextSameIdentifier; + PrevIdentifier.NextSameIdentifier:=Identifier.NextSameIdentifier; Identifier.Free; - Identifier:=LastIdentifier.NextSameIdentifier; + Identifier:=PrevIdentifier.NextSameIdentifier; end else begin FItems.Remove(Identifier); - LastIdentifier:=Identifier; + PrevIdentifier:=Identifier; Identifier:=Identifier.NextSameIdentifier; - LastIdentifier.Free; - LastIdentifier:=nil; + PrevIdentifier.Free; + PrevIdentifier:=nil; if Identifier<>nil then - FItems.Add(LoName,Identifier); + FItems.Add(Loname,Identifier); end; Result:=true; continue; end; - LastIdentifier:=Identifier; + PrevIdentifier:=Identifier; Identifier:=Identifier.NextSameIdentifier; end; end; @@ -3919,16 +4834,26 @@ begin end; procedure TPasIdentifierScope.IterateElements(const aName: string; - const OnIterateElement: TIterateScopeElement; Data: Pointer; - var Abort: boolean); + StartScope: TPasScope; const OnIterateElement: TIterateScopeElement; + Data: Pointer; var Abort: boolean); var Item: TPasIdentifier; + {$IFDEF VerbosePasResolver} + OldElement: TPasElement; + {$ENDIF} begin - Item:=FindIdentifier(aName); + Item:=InternalFindIdentifier(aName); while Item<>nil do begin - // writeln('TPasIdentifierScope.IterateElements ',Item.Identifier,' ',GetObjName(Item.Element)); - OnIterateElement(Item.Element,Self,Data,Abort); + writeln('TPasIdentifierScope.IterateElements ',ClassName,' ',Item.Identifier,' ',GetObjName(Item.Element)); + {$IFDEF VerbosePasResolver} + OldElement:=Item.Element; + {$ENDIF} + OnIterateElement(Item.Element,Self,StartScope,Data,Abort); + {$IFDEF VerbosePasResolver} + if OldElement<>Item.Element then + raise Exception.Create('20160925183503'); + {$ENDIF} if Abort then exit; Item:=Item.NextSameIdentifier; end; diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index b4103ab66c..b9d846129a 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -100,8 +100,11 @@ type TPasMemberHint = (hDeprecated,hLibrary,hPlatform,hExperimental,hUnimplemented); TPasMemberHints = set of TPasMemberHint; + TPasElement = class; TPTreeElement = class of TPasElement; + TOnForEachPasElement = procedure(El: TPasElement; arg: pointer) of object; + { TPasElement } TPasElement = class(TPasElementBase) @@ -124,8 +127,10 @@ type destructor Destroy; override; procedure AddRef; procedure Release; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); virtual; + procedure ForEachChildCall(const aMethodCall: TOnForEachPasElement; + const Arg: Pointer; Child: TPasElement; CheckParent: boolean); virtual; function FullPath: string; function ParentPath: string; function FullName: string; virtual; // Name including parent's names @@ -135,6 +140,7 @@ type Function HintsString : String; function GetDeclaration(full : Boolean) : string; virtual; procedure Accept(Visitor: TPassTreeVisitor); override; + function HasParent(aParent: TPasElement): boolean; property RefCount: LongWord read FRefCount; property Name: string read FName write FName; property Parent: TPasElement read FParent Write FParent; @@ -172,7 +178,7 @@ type constructor Create(AParent : TPasElement; AOperand: TPasExpr; AOpCode: TExprOpCode); overload; function GetDeclaration(full : Boolean) : string; override; destructor Destroy; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; end; @@ -185,7 +191,7 @@ type constructor CreateRange(AParent : TPasElement; xleft, xright: TPasExpr); overload; function GetDeclaration(full : Boolean) : string; override; destructor Destroy; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; end; @@ -235,7 +241,7 @@ type function GetDeclaration(full : Boolean) : string; override; destructor Destroy; override; procedure AddParam(xp: TPasExpr); - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; end; @@ -252,7 +258,7 @@ type destructor Destroy; override; procedure AddField(const AName: AnsiString; Value: TPasExpr); function GetDeclaration(full : Boolean) : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; end; @@ -264,7 +270,7 @@ type destructor Destroy; override; procedure AddValues(AValue: TPasExpr); function GetDeclaration(full : Boolean) : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; end; @@ -275,7 +281,7 @@ type constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; function ElementTypeName: string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public Declarations: TFPList; // list of TPasElement @@ -291,7 +297,7 @@ type constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; procedure AddUnitToUsesList(const AUnitName: string); - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public UsesList: TFPList; // TPasUnresolvedTypeRef or TPasModule elements @@ -323,7 +329,7 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public InterfaceSection: TInterfaceSection; @@ -346,7 +352,7 @@ type Public destructor Destroy; override; function ElementTypeName: string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; Public ProgramSection: TProgramSection; @@ -359,7 +365,7 @@ type Public destructor Destroy; override; function ElementTypeName: string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; Public LibrarySection: TLibrarySection; @@ -373,7 +379,7 @@ type constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; function ElementTypeName: string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public Modules: TFPList; // List of TPasModule objects @@ -386,7 +392,7 @@ type Destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : Boolean) : string; Override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public Expr: TPasExpr; @@ -406,7 +412,7 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : Boolean): string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public DestType: TPasType; @@ -419,7 +425,7 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : Boolean): string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public DestType: TPasType; @@ -447,7 +453,7 @@ type public function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public RangeExpr : TBinaryExpr; @@ -463,7 +469,7 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public IndexRange : string; @@ -480,7 +486,7 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public ElType: TPasType; @@ -491,7 +497,7 @@ type TPasEnumValue = class(TPasElement) public function ElementTypeName: string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public Value: TPasExpr; @@ -508,7 +514,7 @@ type function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; Procedure GetEnumNames(Names : TStrings); - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public Values: TFPList; // List of TPasEnumValue objects @@ -521,7 +527,7 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public EnumType: TPasType; @@ -536,7 +542,7 @@ type constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; function GetDeclaration(full : boolean) : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public Values: TFPList; // list of TPasElement @@ -553,7 +559,7 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public PackMode: TPackMode; @@ -576,7 +582,7 @@ type constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; function ElementTypeName: string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public PackMode: TPackMode; @@ -607,7 +613,7 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public Access: TArgumentAccess; @@ -627,7 +633,7 @@ type function GetDeclaration(full : boolean) : string; override; procedure GetArguments(List : TStrings); function CreateArgument(const AName, AUnresolvedTypeName: string):TPasArgument; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public IsOfObject: Boolean; @@ -642,7 +648,7 @@ type public destructor Destroy; override; function ElementTypeName : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public ResultType: TPasType; @@ -656,7 +662,7 @@ type class function TypeName: string; override; function ElementTypeName: string; override; function GetDeclaration(Full : boolean) : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public ResultEl: TPasResultElement; @@ -692,7 +698,7 @@ type TPasTypeRef = class(TPasUnresolvedTypeRef) public - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public RefType: TPasType; @@ -707,7 +713,7 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public VarType: TPasType; @@ -728,7 +734,7 @@ type Destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; end; @@ -749,7 +755,7 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public IndexExpr: TPasExpr; @@ -782,7 +788,7 @@ type destructor Destroy; override; function ElementTypeName: string; override; function TypeName: string; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public Overloads: TFPList; // List of TPasProcedure nodes @@ -812,7 +818,7 @@ type function TypeName: string; override; function GetDeclaration(full: Boolean): string; override; procedure GetModifiers(List: TStrings); - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public ProcType : TPasProcedureType; @@ -942,7 +948,7 @@ Type public constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public Body: TPasImplBlock; @@ -1043,13 +1049,16 @@ Type function AddForLoop(AVarName : TPasExpr; AStartValue, AEndValue: TPasExpr; ADownTo: Boolean = false): TPasImplForLoop; function AddTry: TPasImplTry; - function AddExceptOn(const VarName, TypeName: TPasExpr): TPasImplExceptOn; + function AddExceptOn(const VarName, TypeName: string): TPasImplExceptOn; + function AddExceptOn(const VarName: string; VarType: TPasType): TPasImplExceptOn; + function AddExceptOn(const VarEl: TPasVariable): TPasImplExceptOn; + function AddExceptOn(const TypeEl: TPasType): TPasImplExceptOn; function AddRaise: TPasImplRaise; function AddLabelMark(const Id: string): TPasImplLabelMark; function AddAssign(left, right: TPasExpr): TPasImplAssign; function AddSimple(exp: TPasExpr): TPasImplSimple; function CloseOnSemicolon: boolean; virtual; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public Elements: TFPList; // list of TPasImplElement and maybe one TPasImplCaseElse @@ -1095,7 +1104,7 @@ Type ConditionExpr : TPasExpr; destructor Destroy; override; Function Condition: string; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; end; @@ -1106,7 +1115,7 @@ Type destructor Destroy; override; procedure AddElement(Element: TPasImplElement); override; function CloseOnSemicolon: boolean; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public ConditionExpr: TPasExpr; @@ -1121,7 +1130,7 @@ Type public destructor Destroy; override; procedure AddElement(Element: TPasImplElement); override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public ConditionExpr : TPasExpr; @@ -1137,7 +1146,7 @@ Type destructor Destroy; override; procedure AddElement(Element: TPasImplElement); override; procedure AddExpression(const Expression: TPasExpr); - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public Expressions: TFPList; // list of TPasExpr @@ -1155,7 +1164,7 @@ Type procedure AddElement(Element: TPasImplElement); override; function AddCase(const Expression: TPasExpr): TPasImplCaseStatement; function AddElse: TPasImplCaseElse; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public CaseExpr : TPasExpr; @@ -1171,7 +1180,7 @@ Type destructor Destroy; override; procedure AddElement(Element: TPasImplElement); override; procedure AddExpression(const Expr: TPasExpr); - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public Expressions: TFPList; // list of TPasExpr @@ -1189,7 +1198,7 @@ Type public destructor Destroy; override; procedure AddElement(Element: TPasImplElement); override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public VariableName : TPasExpr; @@ -1211,7 +1220,7 @@ Type right : TPasExpr; Kind : TAssignKind; Destructor Destroy; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; end; @@ -1221,7 +1230,7 @@ Type public expr : TPasExpr; Destructor Destroy; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; end; @@ -1238,7 +1247,7 @@ Type function AddFinally: TPasImplTryFinally; function AddExcept: TPasImplTryExcept; function AddExceptElse: TPasImplTryExceptElse; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public FinallyExcept: TPasImplTryHandler; @@ -1269,10 +1278,11 @@ Type public destructor Destroy; override; procedure AddElement(Element: TPasImplElement); override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; public - VarExpr,TypeExpr : TPasExpr; + VarEl: TPasVariable; // can be nil + TypeEl : TPasType; Body: TPasImplElement; Function VariableName : String; Function TypeName: string; @@ -1283,7 +1293,7 @@ Type TPasImplRaise = class(TPasImplStatement) public destructor Destroy; override; - procedure ForEachCall(const aMethodCall: TListCallback; + procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; Public ExceptObject, @@ -1381,12 +1391,11 @@ end; { TPasTypeRef } -procedure TPasTypeRef.ForEachCall(const aMethodCall: TListCallback; +procedure TPasTypeRef.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if RefType<>nil then - RefType.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,RefType,true); end; { TPasClassOperator } @@ -1427,14 +1436,12 @@ begin Inherited; end; -procedure TPasImplRaise.ForEachCall(const aMethodCall: TListCallback; +procedure TPasImplRaise.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if ExceptObject<>nil then - ExceptObject.ForEachCall(aMethodCall,Arg); - if ExceptAddr<>nil then - ExceptAddr.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,ExceptObject,false); + ForEachChildCall(aMethodCall,Arg,ExceptAddr,false); end; { TPasImplRepeatUntil } @@ -1454,11 +1461,10 @@ begin end; procedure TPasImplRepeatUntil.ForEachCall( - const aMethodCall: TListCallback; const Arg: Pointer); + const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if ConditionExpr<>nil then - ConditionExpr.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,ConditionExpr,false); end; { TPasImplSimple } @@ -1469,12 +1475,11 @@ begin inherited Destroy; end; -procedure TPasImplSimple.ForEachCall(const aMethodCall: TListCallback; +procedure TPasImplSimple.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if expr<>nil then - expr.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,Expr,false); end; { TPasImplAssign } @@ -1486,14 +1491,12 @@ begin inherited Destroy; end; -procedure TPasImplAssign.ForEachCall(const aMethodCall: TListCallback; +procedure TPasImplAssign.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if left<>nil then - left.ForEachCall(aMethodCall,Arg); - if right<>nil then - right.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,left,false); + ForEachChildCall(aMethodCall,Arg,right,false); end; { TPasExportSymbol } @@ -1519,14 +1522,12 @@ begin Result:=Result+' index '+ExportIndex.GetDeclaration(Full); end; -procedure TPasExportSymbol.ForEachCall(const aMethodCall: TListCallback; +procedure TPasExportSymbol.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if ExportName<>nil then - ExportName.ForEachCall(aMethodCall,Arg); - if ExportIndex<>nil then - ExportIndex.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,ExportName,false); + ForEachChildCall(aMethodCall,Arg,ExportIndex,false); end; { TPasUnresolvedUnitRef } @@ -1549,11 +1550,10 @@ begin Result:=inherited ElementTypeName; end; -procedure TPasLibrary.ForEachCall(const aMethodCall: TListCallback; +procedure TPasLibrary.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin - if LibrarySection<>nil then - LibrarySection.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,LibrarySection,false); inherited ForEachCall(aMethodCall, Arg); end; @@ -1570,11 +1570,10 @@ begin Result:=inherited ElementTypeName; end; -procedure TPasProgram.ForEachCall(const aMethodCall: TListCallback; +procedure TPasProgram.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin - if ProgramSection<>nil then - ProgramSection.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,ProgramSection,false); inherited ForEachCall(aMethodCall, Arg); end; @@ -1615,27 +1614,27 @@ end; function TPasDeclarations.ElementTypeName: string; begin Result := SPasTreeSection end; -procedure TPasDeclarations.ForEachCall(const aMethodCall: TListCallback; +procedure TPasDeclarations.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); for i:=0 to Declarations.Count-1 do - TPasElement(Declarations[i]).ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasElement(Declarations[i]),false); end; function TPasModule.ElementTypeName: string; begin Result := SPasTreeModule end; function TPasPackage.ElementTypeName: string; begin Result := SPasTreePackage end; -procedure TPasPackage.ForEachCall(const aMethodCall: TListCallback; +procedure TPasPackage.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); for i:=0 to Modules.Count-1 do - TPasModule(Modules[i]).ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasModule(Modules[i]),true); end; function TPasResString.ElementTypeName: string; begin Result := SPasTreeResString end; @@ -1649,12 +1648,11 @@ function TPasArrayType.ElementTypeName: string; begin Result := SPasTreeArrayTyp function TPasFileType.ElementTypeName: string; begin Result := SPasTreeFileType end; function TPasEnumValue.ElementTypeName: string; begin Result := SPasTreeEnumValue end; -procedure TPasEnumValue.ForEachCall(const aMethodCall: TListCallback; +procedure TPasEnumValue.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if Value<>nil then - Value.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,Value,false); end; destructor TPasEnumValue.Destroy; @@ -1678,12 +1676,11 @@ function TPasArgument.ElementTypeName: string; begin Result := SPasTreeArgument function TPasProcedureType.ElementTypeName: string; begin Result := SPasTreeProcedureType end; function TPasResultElement.ElementTypeName: string; begin Result := SPasTreeResultElement end; -procedure TPasResultElement.ForEachCall(const aMethodCall: TListCallback; +procedure TPasResultElement.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if ResultType<>nil then - ResultType.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,ResultType,true); end; function TPasFunctionType.ElementTypeName: string; begin Result := SPasTreeFunctionType end; @@ -1863,12 +1860,20 @@ begin {$ifdef debugrefcount} Writeln('Released : ',Cn); {$endif} end; -procedure TPasElement.ForEachCall(const aMethodCall: TListCallback; +procedure TPasElement.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin aMethodCall(Self,Arg); end; +procedure TPasElement.ForEachChildCall(const aMethodCall: TOnForEachPasElement; + const Arg: Pointer; Child: TPasElement; CheckParent: boolean); +begin + if (Child=nil) then exit; + if CheckParent and (not Child.HasParent(Self)) then exit; + Child.ForEachCall(aMethodCall,Arg); +end; + function TPasElement.FullPath: string; var @@ -1957,6 +1962,19 @@ begin Visitor.Visit(Self); end; +function TPasElement.HasParent(aParent: TPasElement): boolean; +var + El: TPasElement; +begin + El:=Parent; + while El<>nil do + begin + if El=aParent then exit(true); + El:=El.Parent; + end; + Result:=false; +end; + constructor TPasDeclarations.Create(const AName: string; AParent: TPasElement); begin inherited Create(AName, AParent); @@ -2082,14 +2100,14 @@ begin end; end; -procedure TPasEnumType.ForEachCall(const aMethodCall: TListCallback; +procedure TPasEnumType.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); for i:=0 to Values.Count-1 do - TPasEnumValue(Values[i]).ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasEnumValue(Values[i]),false); end; @@ -2148,16 +2166,15 @@ begin end; end; -procedure TPasVariant.ForEachCall(const aMethodCall: TListCallback; +procedure TPasVariant.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); for i:=0 to Values.Count-1 do - TPasElement(Values[i]).ForEachCall(aMethodCall,Arg); - if Members<>nil then - Members.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasElement(Values[i]),false); + ForEachChildCall(aMethodCall,Arg,Members,false); end; { TPasRecordType } @@ -2237,25 +2254,22 @@ begin end; end; -procedure TPasClassType.ForEachCall(const aMethodCall: TListCallback; +procedure TPasClassType.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); - if AncestorType<>nil then - AncestorType.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,AncestorType,true); for i:=0 to Interfaces.Count-1 do - TPasElement(Interfaces[i]).ForEachCall(aMethodCall,Arg); - if HelperForType<>nil then - HelperForType.ForEachCall(aMethodCall,Arg); - if GUIDExpr<>nil then - GUIDExpr.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasElement(Interfaces[i]),true); + ForEachChildCall(aMethodCall,Arg,HelperForType,true); + ForEachChildCall(aMethodCall,Arg,GUIDExpr,false); for i:=0 to Members.Count-1 do - TPasElement(Members[i]).ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasElement(Members[i]),false); for i:=0 to GenericTemplateTypes.Count-1 do - TPasElement(GenericTemplateTypes[i]).ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasElement(GenericTemplateTypes[i]),false); end; function TPasClassType.FindMember(MemberClass: TPTreeElement; const MemberName: String): TPasElement; @@ -2355,14 +2369,14 @@ begin Result.ArgType := TPasUnresolvedTypeRef.Create(AUnresolvedTypeName, Result); end; -procedure TPasProcedureType.ForEachCall(const aMethodCall: TListCallback; +procedure TPasProcedureType.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); for i:=0 to Args.Count-1 do - TPasElement(Args[i]).ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasElement(Args[i]),false); end; { TPasResultElement } @@ -2455,13 +2469,13 @@ begin end; procedure TPasOverloadedProc.ForEachCall( - const aMethodCall: TListCallback; const Arg: Pointer); + const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); for i:=0 to Overloads.Count-1 do - TPasProcedure(Overloads[i]).ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasProcedure(Overloads[i]),false); end; function TPasProcedure.GetCallingConvention: TCallingConvention; @@ -2577,16 +2591,13 @@ begin Result:=ElseBranch<>nil; end; -procedure TPasImplIfElse.ForEachCall(const aMethodCall: TListCallback; +procedure TPasImplIfElse.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if ConditionExpr<>nil then - ConditionExpr.ForEachCall(aMethodCall,Arg); - if IfBranch<>nil then - IfBranch.ForEachCall(aMethodCall,Arg); - if ElseBranch<>nil then - ElseBranch.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,ConditionExpr,false); + ForEachChildCall(aMethodCall,Arg,IfBranch,false); + ForEachChildCall(aMethodCall,Arg,ElseBranch,false); end; function TPasImplIfElse.Condition: string; @@ -2617,20 +2628,15 @@ begin raise Exception.Create('TPasImplForLoop.AddElement body already set - please report this bug'); end; -procedure TPasImplForLoop.ForEachCall(const aMethodCall: TListCallback; +procedure TPasImplForLoop.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if VariableName<>nil then - VariableName.ForEachCall(aMethodCall,Arg); - if Variable<>nil then - Variable.ForEachCall(aMethodCall,Arg); - if StartExpr<>nil then - StartExpr.ForEachCall(aMethodCall,Arg); - if EndExpr<>nil then - EndExpr.ForEachCall(aMethodCall,Arg); - if Body<>nil then - Body.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,VariableName,false); + ForEachChildCall(aMethodCall,Arg,Variable,false); + ForEachChildCall(aMethodCall,Arg,StartExpr,false); + ForEachChildCall(aMethodCall,Arg,EndExpr,false); + ForEachChildCall(aMethodCall,Arg,Body,false); end; function TPasImplForLoop.Down: boolean; @@ -2756,12 +2762,35 @@ begin AddElement(Result); end; -function TPasImplBlock.AddExceptOn(const VarName, TypeName: TPasExpr +function TPasImplBlock.AddExceptOn(const VarName, TypeName: string ): TPasImplExceptOn; +begin + Result:=AddExceptOn(VarName,TPasUnresolvedTypeRef.Create(TypeName,nil)); +end; + +function TPasImplBlock.AddExceptOn(const VarName: string; VarType: TPasType + ): TPasImplExceptOn; +var + V: TPasVariable; +begin + V:=TPasVariable.Create(VarName,nil); + V.VarType:=VarType; + Result:=AddExceptOn(V); +end; + +function TPasImplBlock.AddExceptOn(const VarEl: TPasVariable): TPasImplExceptOn; begin Result:=TPasImplExceptOn.Create('',Self); - Result.VarExpr:=VarName; - Result.TypeExpr:=TypeName; + Result.VarEl:=VarEl; + Result.TypeEl:=VarEl.VarType; + Result.TypeEl.AddRef; + AddElement(Result); +end; + +function TPasImplBlock.AddExceptOn(const TypeEl: TPasType): TPasImplExceptOn; +begin + Result:=TPasImplExceptOn.Create('',Self); + Result.TypeEl:=TypeEl; AddElement(Result); end; @@ -2798,14 +2827,14 @@ begin Result:=false; end; -procedure TPasImplBlock.ForEachCall(const aMethodCall: TListCallback; +procedure TPasImplBlock.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); for i:=0 to Elements.Count-1 do - TPasElement(Elements[i]).ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasElement(Elements[i]),false); end; @@ -2819,18 +2848,14 @@ begin Result := 'Unit ' + Name; end; -procedure TPasModule.ForEachCall(const aMethodCall: TListCallback; +procedure TPasModule.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if InterfaceSection<>nil then - InterfaceSection.ForEachCall(aMethodCall,Arg); - if ImplementationSection<>nil then - ImplementationSection.ForEachCall(aMethodCall,Arg); - if InitializationSection<>nil then - InitializationSection.ForEachCall(aMethodCall,Arg); - if FinalizationSection<>nil then - FinalizationSection.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,InterfaceSection,false); + ForEachChildCall(aMethodCall,Arg,ImplementationSection,false); + ForEachChildCall(aMethodCall,Arg,InitializationSection,false); + ForEachChildCall(aMethodCall,Arg,FinalizationSection,false); end; { @@ -2850,12 +2875,11 @@ begin end; end; -procedure TPasResString.ForEachCall(const aMethodCall: TListCallback; +procedure TPasResString.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if Expr<>nil then - Expr.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,Expr,false); end; destructor TPasResString.Destroy; @@ -2875,12 +2899,11 @@ begin end; end; -procedure TPasPointerType.ForEachCall(const aMethodCall: TListCallback; +procedure TPasPointerType.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if DestType<>nil then - DestType.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,DestType,true); end; function TPasAliasType.GetDeclaration(full: Boolean): string; @@ -2893,12 +2916,11 @@ begin end; end; -procedure TPasAliasType.ForEachCall(const aMethodCall: TListCallback; +procedure TPasAliasType.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if DestType<>nil then - DestType.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,DestType,true); end; function TPasClassOfType.GetDeclaration (full : boolean) : string; @@ -2921,12 +2943,11 @@ begin end; end; -procedure TPasRangeType.ForEachCall(const aMethodCall: TListCallback; +procedure TPasRangeType.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if RangeExpr<>nil then - RangeExpr.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,RangeExpr,false); end; destructor TPasRangeType.Destroy; @@ -2964,12 +2985,11 @@ begin end; end; -procedure TPasArrayType.ForEachCall(const aMethodCall: TListCallback; +procedure TPasArrayType.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if ElType<>nil then - ElType.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,ElType,true); end; function TPasArrayType.IsGenericArray: Boolean; @@ -2994,12 +3014,11 @@ begin end; end; -procedure TPasFileType.ForEachCall(const aMethodCall: TListCallback; +procedure TPasFileType.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if ElType<>nil then - ElType.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,ElType,true); end; Function IndentStrings(S : TStrings; indent : Integer) : string; @@ -3083,12 +3102,11 @@ begin ProcessHints(False,Result); end; -procedure TPasSetType.ForEachCall(const aMethodCall: TListCallback; +procedure TPasSetType.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if EnumType<>nil then - EnumType.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,EnumType,true); end; procedure TPasRecordType.GetMembers(S: TStrings); @@ -3174,19 +3192,18 @@ begin end; end; -procedure TPasRecordType.ForEachCall(const aMethodCall: TListCallback; +procedure TPasRecordType.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); for i:=0 to Members.Count-1 do - TPasElement(Members[i]).ForEachCall(aMethodCall,Arg); - if VariantEl<>nil then - VariantEl.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasElement(Members[i]),false); + ForEachChildCall(aMethodCall,Arg,VariantEl,false); if Variants<>nil then for i:=0 to Variants.Count-1 do - TPasElement(Variants[i]).ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasElement(Variants[i]),false); end; function TPasRecordType.IsPacked: Boolean; @@ -3293,12 +3310,11 @@ begin end; end; -procedure TPasFunctionType.ForEachCall(const aMethodCall: TListCallback; +procedure TPasFunctionType.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if ResultEl<>nil then - ResultEl.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,ResultEl,false); end; function TPasVariable.GetDeclaration (full : boolean) : string; @@ -3326,14 +3342,12 @@ begin end; end; -procedure TPasVariable.ForEachCall(const aMethodCall: TListCallback; +procedure TPasVariable.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if VarType<>nil then - VarType.ForEachCall(aMethodCall,Arg); - if Expr<>nil then - Expr.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,VarType,true); + ForEachChildCall(aMethodCall,Arg,Expr,false); end; @@ -3384,26 +3398,20 @@ begin ProcessHints(True, Result); end; -procedure TPasProperty.ForEachCall(const aMethodCall: TListCallback; +procedure TPasProperty.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); - if IndexExpr<>nil then - IndexExpr.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,IndexExpr,false); 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); + ForEachChildCall(aMethodCall,Arg,TPasElement(Args[i]),false); + ForEachChildCall(aMethodCall,Arg,ReadAccessor,false); + ForEachChildCall(aMethodCall,Arg,WriteAccessor,false); + ForEachChildCall(aMethodCall,Arg,ImplementsFunc,false); + ForEachChildCall(aMethodCall,Arg,StoredAccessor,false); + ForEachChildCall(aMethodCall,Arg,DefaultExpr,false); end; function TPasProperty.ResolvedType: TPasType; @@ -3476,20 +3484,15 @@ begin DoAdd(IsMessage,' Message'); end; -procedure TPasProcedure.ForEachCall(const aMethodCall: TListCallback; +procedure TPasProcedure.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if PublicName<>nil then - PublicName.ForEachCall(aMethodCall,Arg); - if ProcType<>nil then - ProcType.ForEachCall(aMethodCall,Arg); - if LibraryExpr<>nil then - LibraryExpr.ForEachCall(aMethodCall,Arg); - if LibrarySymbolName<>nil then - LibrarySymbolName.ForEachCall(aMethodCall,Arg); - if Body<>nil then - Body.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,PublicName,false); + ForEachChildCall(aMethodCall,Arg,ProcType,false); + ForEachChildCall(aMethodCall,Arg,LibraryExpr,false); + ForEachChildCall(aMethodCall,Arg,LibrarySymbolName,false); + ForEachChildCall(aMethodCall,Arg,Body,false); end; procedure TPasProcedure.AddModifier(AModifier: TProcedureModifier); @@ -3694,14 +3697,12 @@ begin Result:=''; end; -procedure TPasArgument.ForEachCall(const aMethodCall: TListCallback; +procedure TPasArgument.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if ArgType<>nil then - ArgType.ForEachCall(aMethodCall,Arg); - if ValueExpr<>nil then - ValueExpr.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,ArgType,false); + ForEachChildCall(aMethodCall,Arg,ValueExpr,false); end; function TPasArgument.Value: String; @@ -3743,14 +3744,14 @@ begin UsesList.Add(TPasUnresolvedTypeRef.Create(AUnitName, Self)); end; -procedure TPasSection.ForEachCall(const aMethodCall: TListCallback; +procedure TPasSection.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); for i:=0 to UsesList.Count-1 do - TPasElement(UsesList[i]).ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasElement(UsesList[i]),true); end; { TProcedureBody } @@ -3767,12 +3768,11 @@ begin inherited Destroy; end; -procedure TProcedureBody.ForEachCall(const aMethodCall: TListCallback; +procedure TProcedureBody.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if Body<>nil then - Body.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,Body,false); end; { TPasImplWhileDo } @@ -3796,14 +3796,12 @@ begin raise Exception.Create('TPasImplWhileDo.AddElement body already set - please report this bug'); end; -procedure TPasImplWhileDo.ForEachCall(const aMethodCall: TListCallback; +procedure TPasImplWhileDo.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if ConditionExpr<>nil then - ConditionExpr.ForEachCall(aMethodCall,Arg); - if Body<>nil then - Body.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,ConditionExpr,false); + ForEachChildCall(aMethodCall,Arg,Body,false); end; function TPasImplWhileDo.Condition: string; @@ -3843,14 +3841,12 @@ begin AddElement(Result); end; -procedure TPasImplCaseOf.ForEachCall(const aMethodCall: TListCallback; +procedure TPasImplCaseOf.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if CaseExpr<>nil then - CaseExpr.ForEachCall(aMethodCall,Arg); - if ElseBranch<>nil then - ElseBranch.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,CaseExpr,false); + ForEachChildCall(aMethodCall,Arg,ElseBranch,false); end; function TPasImplCaseOf.Expression: string; @@ -3900,15 +3896,14 @@ begin end; procedure TPasImplCaseStatement.ForEachCall( - const aMethodCall: TListCallback; const Arg: Pointer); + const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); for i:=0 to Expressions.Count-1 do - TPasElement(Expressions[i]).ForEachCall(aMethodCall,Arg); - if Body<>nil then - Body.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasElement(Expressions[i]),false); + ForEachChildCall(aMethodCall,Arg,Body,false); end; { TPasImplWithDo } @@ -3946,16 +3941,15 @@ begin Expressions.Add(Expression); end; -procedure TPasImplWithDo.ForEachCall(const aMethodCall: TListCallback; +procedure TPasImplWithDo.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); for i:=0 to Expressions.Count-1 do - TPasElement(Expressions[i]).ForEachCall(aMethodCall,Arg); - if Body<>nil then - Body.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,TPasElement(Expressions[i]),false); + ForEachChildCall(aMethodCall,Arg,Body,false); end; { TPasImplTry } @@ -3987,22 +3981,20 @@ begin ElseBranch:=Result; end; -procedure TPasImplTry.ForEachCall(const aMethodCall: TListCallback; +procedure TPasImplTry.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if FinallyExcept<>nil then - FinallyExcept.ForEachCall(aMethodCall,Arg); - if ElseBranch<>nil then - ElseBranch.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,FinallyExcept,false); + ForEachChildCall(aMethodCall,Arg,ElseBranch,false); end; { TPasImplExceptOn } destructor TPasImplExceptOn.Destroy; begin - ReleaseAndNil(TPasElement(VarExpr)); - ReleaseAndNil(TPasElement(TypeExpr)); + ReleaseAndNil(TPasElement(VarEl)); + ReleaseAndNil(TPasElement(TypeEl)); ReleaseAndNil(TPasElement(Body)); inherited Destroy; end; @@ -4017,30 +4009,27 @@ begin end; end; -procedure TPasImplExceptOn.ForEachCall(const aMethodCall: TListCallback; +procedure TPasImplExceptOn.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if VarExpr<>nil then - VarExpr.ForEachCall(aMethodCall,Arg); - if TypeExpr<>nil then - TypeExpr.ForEachCall(aMethodCall,Arg); - if Body<>nil then - Body.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,VarEl,false); + ForEachChildCall(aMethodCall,Arg,TypeEl,false); + ForEachChildCall(aMethodCall,Arg,Body,false); end; function TPasImplExceptOn.VariableName: String; begin - If assigned(VarExpr) then - Result:=VarExpr.GetDeclaration(True) + If assigned(VarEl) then + Result:=VarEl.Name else Result:=''; end; function TPasImplExceptOn.TypeName: string; begin - If assigned(TypeExpr) then - Result:=TypeExpr.GetDeclaration(True) + If assigned(TypeEl) then + Result:=TypeEl.GetDeclaration(True) else Result:=''; end; @@ -4115,12 +4104,11 @@ begin Operand.Release; end; -procedure TUnaryExpr.ForEachCall(const aMethodCall: TListCallback; +procedure TUnaryExpr.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if Operand<>nil then - Operand.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,Operand,false); end; { TBinaryExpr } @@ -4195,14 +4183,12 @@ begin inherited Destroy; end; -procedure TBinaryExpr.ForEachCall(const aMethodCall: TListCallback; +procedure TBinaryExpr.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); - if left<>nil then - left.ForEachCall(aMethodCall,Arg); - if right<>nil then - right.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,left,false); + ForEachChildCall(aMethodCall,Arg,right,false); end; { TParamsExpr } @@ -4235,16 +4221,15 @@ begin Params[i]:=xp; end; -procedure TParamsExpr.ForEachCall(const aMethodCall: TListCallback; +procedure TParamsExpr.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); - if Value<>nil then - Value.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,Value,false); for i:=0 to Length(Params)-1 do - Params[i].ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,Params[i],false); end; constructor TParamsExpr.Create(AParent : TPasElement; AKind: TPasExprKind); @@ -4278,7 +4263,7 @@ begin Result:='('+Result+')'; end; -procedure TRecordValues.ForEachCall(const aMethodCall: TListCallback; +procedure TRecordValues.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; @@ -4287,7 +4272,7 @@ begin for i:=0 to length(Fields)-1 do with Fields[i] do if ValueExp<>nil then - ValueExp.ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,ValueExp,false); end; constructor TRecordValues.Create(AParent : TPasElement); @@ -4353,14 +4338,14 @@ begin Result:='('+Result+')'; end; -procedure TArrayValues.ForEachCall(const aMethodCall: TListCallback; +procedure TArrayValues.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); var i: Integer; begin inherited ForEachCall(aMethodCall, Arg); for i:=0 to length(Values)-1 do - Values[i].ForEachCall(aMethodCall,Arg); + ForEachChildCall(aMethodCall,Arg,Values[i],false); end; constructor TArrayValues.Create(AParent : TPasElement); diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index af63668221..1ee500bbbd 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -73,6 +73,7 @@ const nParserDuplicateIdentifier = 2046; nParserDefaultParameterRequiredFor = 2047; nParserOnlyOneVariableCanBeInitialized = 2048; + nParserExpectedTypeButGot = 2049; // resourcestring patterns of messages @@ -125,6 +126,7 @@ resourcestring SParserDuplicateIdentifier = 'Duplicate identifier "%s"'; SParserDefaultParameterRequiredFor = 'Default parameter required for "%s"'; SParserOnlyOneVariableCanBeInitialized = 'Only one variable can be initialized'; + SParserExpectedTypeButGot = 'Expected type, but got %s'; type TPasScopeType = ( @@ -1088,7 +1090,21 @@ begin Ref:=Nil; SS:=(not (po_resolvestandardtypes in FOptions)) and isSimpleTypeToken(Name); if not SS then + begin Ref:=Engine.FindElement(Name); + if Ref=nil then + begin + {$IFDEF VerbosePasResolver} + if po_resolvestandardtypes in FOptions then + begin + writeln('ERROR: TPasParser.ParseSimpleType resolver failed to raise an error'); + ParseExcExpectedIdentifier; + end; + {$ENDIF} + end + else if not (Ref is TPasType) then + ParseExc(nParserExpectedTypeButGot,SParserExpectedTypeButGot,[Ref.ElementTypeName]); + end; if (Ref=Nil) then Ref:=TPasUnresolvedTypeRef(CreateElement(TPasUnresolvedTypeRef,Name,Parent)) else @@ -2341,7 +2357,8 @@ begin if Assigned(TypeEl) then // !!! begin Declarations.Declarations.Add(TypeEl); - if TypeEl.ClassType = TPasClassType then + if (TypeEl.ClassType = TPasClassType) + and (not (po_keepclassforward in Options)) then begin // Remove previous forward declarations, if necessary for i := 0 to Declarations.Classes.Count - 1 do @@ -2407,7 +2424,7 @@ begin begin PropEl:=ParseProperty(Declarations,CurtokenString,visDefault); Declarations.Declarations.Add(PropEl); - Declarations.properties.add(PropEl); + Declarations.properties.Add(PropEl); end; else ParseExcSyntaxError; @@ -3666,6 +3683,9 @@ var ak : TAssignKind; lt : TLoopType; ok: Boolean; + SrcPos: TPasSourcePos; + Name: String; + TypeEl: TPasType; begin NewImplElement:=nil; @@ -3819,10 +3839,11 @@ begin begin // with Expr do // with Expr, Expr do + SrcPos:=Scanner.CurSourcePos; NextToken; Left:=DoParseExpression(Parent); //writeln(i,'WITH Expr="',Expr,'" Token=',CurTokenText); - El:=TPasImplWithDo(CreateElement(TPasImplWithDo,'',CurBlock)); + El:=TPasImplWithDo(CreateElement(TPasImplWithDo,'',CurBlock,SrcPos)); TPasImplWithDo(El).AddExpression(Left); CreateBlock(TPasImplWithDo(El)); repeat @@ -3955,23 +3976,28 @@ begin // on Exception do if CurBlock is TPasImplTryExcept then begin + ExpectIdentifier; + El:=TPasImplExceptOn(CreateElement(TPasImplExceptOn,'',CurBlock)); + SrcPos:=Scanner.CurSourcePos; + Name:=CurTokenString; NextToken; - Left:=Nil; - Right:=DoParseExpression(Parent); - //writeln(i,'ON t=',TypeName,' Token=',CurTokenText); - // NextToken; + //writeln('ON t=',Name,' Token=',CurTokenText); if CurToken=tkColon then begin + // the first expression was the variable name NextToken; - Left:=Right; - Right:=DoParseExpression(Parent); - //writeln(i,'ON v=',VarName,' t=',TypeName,' Token=',CurTokenText); + TypeEl:=ParseSimpleType(El,SrcPos,''); + TPasImplExceptOn(El).TypeEl:=TypeEl; + TPasImplExceptOn(El).VarEl:=TPasVariable(CreateElement(TPasVariable, + Name,El,SrcPos)); + TPasImplExceptOn(El).VarEl.VarType:=TypeEl; + TypeEl.AddRef; + end + else + begin + UngetToken; + TPasImplExceptOn(El).TypeEl:=ParseSimpleType(El,SrcPos,''); end; -// else - UngetToken; - El:=TPasImplExceptOn(CreateElement(TPasImplExceptOn,'',CurBlock)); - TPasImplExceptOn(El).VarExpr:=Left; - TPasImplExceptOn(El).TypeExpr:=Right; Engine.FinishScope(stExceptOnExpr,El); CurBlock.AddElement(El); CurBlock:=TPasImplExceptOn(El); diff --git a/packages/fcl-passrc/src/pscanner.pp b/packages/fcl-passrc/src/pscanner.pp index fd0a82388d..f0fc084d17 100644 --- a/packages/fcl-passrc/src/pscanner.pp +++ b/packages/fcl-passrc/src/pscanner.pp @@ -330,7 +330,8 @@ type 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_nooverloadedprocs // do not create TPasOverloadedProc for procs with same name + po_nooverloadedprocs, // do not create TPasOverloadedProc for procs with same name + po_keepclassforward // default: delete class fowards when there is a class declaration ); TPOptions = set of TPOption; @@ -849,7 +850,8 @@ Procedure TStreamLineReader.InitFromStream(AStream : TStream); begin SetLength(FContent,AStream.Size); - AStream.Read(FContent[1],AStream.Size); + if FContent<>'' then + AStream.Read(FContent[1],length(FContent)); FPos:=0; end; diff --git a/packages/fcl-passrc/tests/tcbaseparser.pas b/packages/fcl-passrc/tests/tcbaseparser.pas index 45132e7715..ba9a688862 100644 --- a/packages/fcl-passrc/tests/tcbaseparser.pas +++ b/packages/fcl-passrc/tests/tcbaseparser.pas @@ -599,6 +599,8 @@ end; procedure TTestParser.StartParsing; +var + i: Integer; begin If FIsUnit then StartImplementation; @@ -608,7 +610,8 @@ begin FResolver.AddStream(FFileName,TStringStream.Create(FSource.Text)); FScanner.OpenFile(FFileName); Writeln('// Test : ',Self.TestName); - Writeln(FSource.Text); + for i:=0 to FSource.Count-1 do + Writeln(Format('%:4d: ',[i+1]),FSource[i]); end; procedure TTestParser.ParseDeclarations; diff --git a/packages/fcl-passrc/tests/tcclasstype.pas b/packages/fcl-passrc/tests/tcclasstype.pas index d8a00f1ec5..e663c08585 100644 --- a/packages/fcl-passrc/tests/tcclasstype.pas +++ b/packages/fcl-passrc/tests/tcclasstype.pas @@ -763,28 +763,28 @@ procedure TTestClassType.TestConstructor; begin AddMember('Constructor Create'); ParseClass; - AssertEquals('1 members',1,TheClass.members.Count); - AssertEquals('1 class procedure',TPasConstructor,members[0].ClassType); + AssertEquals('1 members',1,TheClass.Members.Count); + AssertEquals('1 class procedure',TPasConstructor,Members[0].ClassType); AssertEquals('Default visibility',visDefault,Members[0].Visibility); AssertMemberName('Create'); - AssertEquals('No modifiers',[],TPasClassProcedure(Members[0]).Modifiers); - AssertEquals('Default calling convention',ccDefault, TPasClassProcedure(Members[0]).ProcType.CallingConvention); - AssertNotNull('Method proc type',TPasClassProcedure(Members[0]).ProcType); - AssertEquals('No arguments',0,TPasClassProcedure(Members[0]).ProcType.Args.Count) + AssertEquals('No modifiers',[],TPasConstructor(Members[0]).Modifiers); + AssertEquals('Default calling convention',ccDefault, TPasConstructor(Members[0]).ProcType.CallingConvention); + AssertNotNull('Method proc type',TPasConstructor(Members[0]).ProcType); + AssertEquals('No arguments',0,TPasConstructor(Members[0]).ProcType.Args.Count) end; procedure TTestClassType.TestClassConstructor; begin AddMember('Class Constructor Create'); ParseClass; - AssertEquals('1 members',1,TheClass.members.Count); - AssertEquals('1 class procedure',TPasClassConstructor,members[0].ClassType); + AssertEquals('1 members',1,TheClass.Members.Count); + AssertEquals('1 class procedure',TPasClassConstructor,Members[0].ClassType); AssertEquals('Default visibility',visDefault,Members[0].Visibility); AssertMemberName('Create'); - AssertEquals('No modifiers',[],TPasClassProcedure(Members[0]).Modifiers); - AssertEquals('Default calling convention',ccDefault, TPasClassProcedure(Members[0]).ProcType.CallingConvention); - AssertNotNull('Method proc type',TPasClassProcedure(Members[0]).ProcType); - AssertEquals('No arguments',0,TPasClassProcedure(Members[0]).ProcType.Args.Count) + AssertEquals('No modifiers',[],TPasClassConstructor(Members[0]).Modifiers); + AssertEquals('Default calling convention',ccDefault, TPasClassConstructor(Members[0]).ProcType.CallingConvention); + AssertNotNull('Method proc type',TPasClassConstructor(Members[0]).ProcType); + AssertEquals('No arguments',0,TPasClassConstructor(Members[0]).ProcType.Args.Count) end; procedure TTestClassType.TestDestructor; @@ -795,24 +795,24 @@ begin AssertEquals('1 class procedure',TPasDestructor,members[0].ClassType); AssertEquals('Default visibility',visDefault,Members[0].Visibility); AssertMemberName('Destroy'); - AssertEquals('No modifiers',[],TPasClassProcedure(Members[0]).Modifiers); - AssertEquals('Default calling convention',ccDefault, TPasClassProcedure(Members[0]).ProcType.CallingConvention); - AssertNotNull('Method proc type',TPasClassProcedure(Members[0]).ProcType); - AssertEquals('No arguments',0,TPasClassProcedure(Members[0]).ProcType.Args.Count) + AssertEquals('No modifiers',[],TPasDestructor(Members[0]).Modifiers); + AssertEquals('Default calling convention',ccDefault, TPasDestructor(Members[0]).ProcType.CallingConvention); + AssertNotNull('Method proc type',TPasDestructor(Members[0]).ProcType); + AssertEquals('No arguments',0,TPasDestructor(Members[0]).ProcType.Args.Count) end; procedure TTestClassType.TestClassDestructor; begin AddMember('Class Destructor Destroy'); ParseClass; - AssertEquals('1 members',1,TheClass.members.Count); - AssertEquals('1 class procedure',TPasClassDestructor,members[0].ClassType); + AssertEquals('1 members',1,TheClass.Members.Count); + AssertEquals('1 class procedure',TPasClassDestructor,Members[0].ClassType); AssertEquals('Default visibility',visDefault,Members[0].Visibility); AssertMemberName('Destroy'); - AssertEquals('No modifiers',[],TPasClassProcedure(Members[0]).Modifiers); - AssertEquals('Default calling convention',ccDefault, TPasClassProcedure(Members[0]).ProcType.CallingConvention); - AssertNotNull('Method proc type',TPasClassProcedure(Members[0]).ProcType); - AssertEquals('No arguments',0,TPasClassProcedure(Members[0]).ProcType.Args.Count) + AssertEquals('No modifiers',[],TPasClassDestructor(Members[0]).Modifiers); + AssertEquals('Default calling convention',ccDefault, TPasClassDestructor(Members[0]).ProcType.CallingConvention); + AssertNotNull('Method proc type',TPasClassDestructor(Members[0]).ProcType); + AssertEquals('No arguments',0,TPasClassDestructor(Members[0]).ProcType.Args.Count) end; procedure TTestClassType.TestFunctionMethodSimple; diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 5751995ba9..3d05e8bdbd 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -73,8 +73,8 @@ Type function GetModuleCount: integer; function GetModules(Index: integer): TTestEnginePasResolver; function OnPasResolverFindUnit(const aUnitName: String): TPasModule; - procedure OnFindReference(Element, FindData: pointer); - procedure OnCheckElementParent(data, arg: pointer); + procedure OnFindReference(El: TPasElement; FindData: pointer); + procedure OnCheckElementParent(El: TPasElement; arg: pointer); Protected Procedure SetUp; override; Procedure TearDown; override; @@ -109,12 +109,26 @@ Type Procedure TestPrgAssignment; Procedure TestPrgProcVar; Procedure TestUnitProcVar; + Procedure TestAssignIntegers; + Procedure TestAssignString; + Procedure TestAssignIntToStringFail; + Procedure TestIntegerOperators; + Procedure TestBooleanOperators; + Procedure TestStringOperators; + // ToDo: +=, -=, *=, /= // statements Procedure TestForLoop; Procedure TestStatements; Procedure TestCaseStatement; Procedure TestTryStatement; + Procedure TestTryExceptOnNonTypeFail; + Procedure TestTryExceptOnNonClassFail; + Procedure TestRaiseNonVarFail; + Procedure TestRaiseNonClassFail; Procedure TestStatementsRefs; + Procedure TestRepeatUntilNonBoolFail; + Procedure TestWhileDoNonBoolFail; + Procedure TestIfThenNonBoolFail; // units Procedure TestUnitRef; // procs @@ -137,6 +151,8 @@ Type Procedure TestUnitIntfProcUnresolved; Procedure TestUnitIntfMismatchArgName; Procedure TestProcOverloadIsNotFunc; + Procedure TestProcCallMissingParams; + Procedure TestBuiltInProcCallMissingParams; // record Procedure TestRecord; Procedure TestRecordVariant; @@ -157,9 +173,24 @@ Type Procedure TestClassMethodOverload; Procedure TestClassMethodInvalidOverload; Procedure TestClassOverride; + Procedure TestClassOverride2; Procedure TestClassMethodScope; Procedure TestClassIdentifierSelf; Procedure TestClassCallInherited; + Procedure TestClassCallInheritedNoParamsAbstractFail; + Procedure TestClassCallInheritedWithParamsAbstractFail; + Procedure TestClassAssignNil; + Procedure TestClassAssign; + Procedure TestClassNilAsParam; + Procedure TestClassOperator_Is_As; + Procedure TestClassOperatorIsOnNonDescendantFail; + Procedure TestClassOperatorIsOnNonTypeFail; + Procedure TestClassOperatorAsOnNonDescendantFail; + Procedure TestClassOperatorAsOnNonTypeFail; + // ToDo: typecast + // ToDo: as function result + // ToDo: assign constructor result + // property Procedure TestProperty1; Procedure TestPropertyAccessorNotInFront; @@ -180,6 +211,11 @@ Type Procedure TestPropertyStoredAccessorFuncWrongResult; Procedure TestPropertyStoredAccessorFuncWrongArgCount; Procedure TestPropertyArgs1; + // with + Procedure TestWithBlock1; + Procedure TestWithBlock2; + // arrays + Procedure TestDynArrayOfLongint; end; function LinesToStr(Args: array of const): string; @@ -279,8 +315,9 @@ begin on E: EParserError do begin writeln('ERROR: TTestResolver.ParseProgram Parser: '+E.ClassName+':'+E.Message + +' Scanner at' +' File='+Scanner.CurFilename - +' LineNo='+IntToStr(Scanner.CurRow) + +' Row='+IntToStr(Scanner.CurRow) +' Col='+IntToStr(Scanner.CurColumn) +' Line="'+Scanner.CurLine+'"' ); @@ -289,8 +326,9 @@ begin on E: EPasResolve do begin writeln('ERROR: TTestResolver.ParseProgram PasResolver: '+E.ClassName+':'+E.Message + +' Scanner at' +' File='+Scanner.CurFilename - +' LineNo='+IntToStr(Scanner.CurRow) + +' Row='+IntToStr(Scanner.CurRow) +' Col='+IntToStr(Scanner.CurColumn) +' Line="'+Scanner.CurLine+'"' ); @@ -697,10 +735,12 @@ var LabelElements:=nil; ReferenceElements:=nil; try + writeln('CheckDirectReference finding elements at label ...'); LabelElements:=FindElementsAt(aLabel^.Filename,aLabel^.LineNumber,aLabel^.StartCol,aLabel^.EndCol); if LabelElements.Count=0 then RaiseErrorAt('label "'+aLabel^.Identifier+'" has no elements',aLabel); + writeln('CheckDirectReference finding elements at reference ...'); ReferenceElements:=FindElementsAt(aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol,aMarker^.EndCol); if ReferenceElements.Count=0 then RaiseErrorAt('reference "'+aMarker^.Identifier+'" has no elements',aMarker); @@ -708,10 +748,14 @@ var for i:=0 to ReferenceElements.Count-1 do begin El:=TPasElement(ReferenceElements[i]); - //writeln('CheckDirectReference ',i,'/',ReferenceElements.Count,' ',GetTreeDesc(El,2)); + writeln('CheckDirectReference ',i,'/',ReferenceElements.Count,' ',GetTreeDesc(El,2)); if El.ClassType=TPasVariable then begin - AssertNotNull('TPasVariable(El='+El.Name+').VarType',TPasVariable(El).VarType); + if TPasVariable(El).VarType=nil then + begin + writeln('CheckDirectReference Var without Type: ',GetObjName(El),' El.Parent=',GetObjName(El.Parent)); + AssertNotNull('TPasVariable(El='+El.Name+').VarType',TPasVariable(El).VarType); + end; TypeEl:=TPasVariable(El).VarType; for j:=0 to LabelElements.Count-1 do begin @@ -771,6 +815,7 @@ begin LastMarker:=nil; FoundRefs:=Default(TTestResolverReferenceData); try + //writeln('TTestResolver.CheckReferenceDirectives find all markers'); // find all markers for i:=0 to Resolver.Streams.Count-1 do begin @@ -779,6 +824,7 @@ begin SrcLines.Free; end; + //writeln('TTestResolver.CheckReferenceDirectives check references'); // check references aMarker:=FirstMarker; while aMarker<>nil do @@ -789,6 +835,7 @@ begin end; aMarker:=aMarker^.Next; end; + writeln('TTestResolver.CheckReferenceDirectives COMPLETE'); finally while FirstMarker<>nil do @@ -959,14 +1006,13 @@ begin raise Exception.Create('can''t find unit "'+aUnitName+'"'); end; -procedure TTestResolver.OnFindReference(Element, FindData: pointer); +procedure TTestResolver.OnFindReference(El: TPasElement; FindData: pointer); var - El: TPasElement absolute Element; Data: PTestResolverReferenceData absolute FindData; Line, Col: integer; begin ResolverEngine.UnmangleSourceLineNumber(El.SourceLinenumber,Line,Col); - //writeln('TTestResolver.OnFindReference ',El.SourceFilename,' Line=',Line,',Col=',Col,' ',GetObjName(El),' 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) @@ -975,10 +1021,9 @@ begin Data^.Found.Add(El); end; -procedure TTestResolver.OnCheckElementParent(data, arg: pointer); +procedure TTestResolver.OnCheckElementParent(El: TPasElement; arg: pointer); var SubEl: TPasElement; - El: TPasElement absolute Data; i: Integer; procedure E(Msg: string); @@ -993,7 +1038,10 @@ var begin if arg=nil then ; - //writeln('TTestResolver.OnCheckElementParent ',GetObjName(El)); + writeln('TTestResolver.OnCheckElementParent ',GetObjName(El)); + if El=nil then exit; + if El.Parent=El then + E('El.Parent=El='+GetObjName(El)); if El is TBinaryExpr then begin if (TBinaryExpr(El).left<>nil) and (TBinaryExpr(El).left.Parent<>El) then @@ -1026,6 +1074,15 @@ begin if SubEl.Parent<>El then E('TPasElement(TPasImplBlock(El).Elements[i]).Parent='+GetObjName(SubEl.Parent)+'<>El'); end; + end + else if El is TPasImplWithDo then + begin + for i:=0 to TPasImplWithDo(El).Expressions.Count-1 do + begin + SubEl:=TPasExpr(TPasImplWithDo(El).Expressions[i]); + if SubEl.Parent<>El then + E('TPasExpr(TPasImplWithDo(El).Expressions[i]).Parent='+GetObjName(SubEl.Parent)+'<>El'); + end; end; end; @@ -1325,6 +1382,146 @@ begin AssertSame('proc sub var type is proc sub t1',ProcSubType1,ProcSubVar1Type); end; +procedure TTestResolver.TestAssignIntegers; +begin + StartProgram(false); + Add('var'); + Add(' {#vbyte}vbyte:byte;'); + Add(' {#vshortint}vshortint:shortint;'); + Add(' {#vword}vword:word;'); + Add(' {#vsmallint}vsmallint:smallint;'); + Add(' {#vcardinal}vcardinal:cardinal;'); + Add(' {#vlongint}vlongint:longint;'); + Add(' {#vint64}vint64:int64;'); + Add(' {#vcomp}vcomp:comp;'); + Add('begin'); + Add(' {@vbyte}vbyte:=0;'); + Add(' {@vbyte}vbyte:=255;'); + Add(' {@vshortint}vshortint:=0;'); + Add(' {@vshortint}vshortint:=-128;'); + Add(' {@vshortint}vshortint:= 127;'); + Add(' {@vword}vword:=0;'); + Add(' {@vword}vword:=+$ffff;'); + Add(' {@vsmallint}vsmallint:=0;'); + Add(' {@vsmallint}vsmallint:=-$8000;'); + Add(' {@vsmallint}vsmallint:= $7fff;'); + Add(' {@vcardinal}vcardinal:=0;'); + Add(' {@vcardinal}vcardinal:=$ffffffff;'); + Add(' {@vlongint}vlongint:=0;'); + Add(' {@vlongint}vlongint:=-$80000000;'); + Add(' {@vlongint}vlongint:= $7fffffff;'); + Add(' {@vlongint}vlongint:={@vbyte}vbyte;'); + Add(' {@vlongint}vlongint:={@vshortint}vshortint;'); + Add(' {@vlongint}vlongint:={@vword}vword;'); + Add(' {@vlongint}vlongint:={@vsmallint}vsmallint;'); + Add(' {@vlongint}vlongint:={@vlongint}vlongint;'); + Add(' {@vcomp}vcomp:=0;'); + Add(' {@vcomp}vcomp:=$ffffffffffffffff;'); + Add(' {@vint64}vint64:=0;'); + Add(' {@vint64}vint64:=-$8000000000000000;'); + Add(' {@vint64}vint64:= $7fffffffffffffff;'); + ParseProgram; +end; + +procedure TTestResolver.TestAssignString; +begin + StartProgram(false); + Add('var'); + Add(' vstring:string;'); + Add(' vchar:char;'); + Add('begin'); + Add(' vstring:='''';'); + Add(' vstring:=''abc'';'); + Add(' vstring:=''a'';'); + Add(' vchar:=''c'';'); + ParseProgram; +end; + +procedure TTestResolver.TestAssignIntToStringFail; +var + ok: Boolean; +begin + StartProgram(false); + Add('var'); + Add(' vstring:string;'); + Add('begin'); + Add(' vstring:=2;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected Incompatible types: got "Longint" expected "String", but got msg number "'+E.Message+'"', + PasResolver.nIncompatibleTypeGotExpected,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('assign int to str fails',true,ok); +end; + +procedure TTestResolver.TestIntegerOperators; +begin + StartProgram(false); + Add('var'); + Add(' i,j,k:longint;'); + Add('begin'); + Add(' i:=1;'); + Add(' i:=1+2;'); + Add(' i:=1+2+3;'); + Add(' i:=1-2;'); + Add(' i:=j;'); + Add(' i:=j+1;'); + Add(' i:=-j+1;'); + Add(' i:=j+k;'); + Add(' i:=-j+k;'); + Add(' i:=j*k;'); + Add(' i:=j div k;'); + Add(' i:=j mod k;'); + Add(' i:=j shl k;'); + Add(' i:=j shr k;'); + Add(' i:=j and k;'); + Add(' i:=j or k;'); + Add(' i:=j and not k;'); + Add(' i:=(j+k) div 3;'); + ParseProgram; +end; + +procedure TTestResolver.TestBooleanOperators; +begin + StartProgram(false); + Add('var'); + Add(' i,j,k:boolean;'); + Add('begin'); + Add(' i:=false;'); + Add(' i:=true;'); + Add(' i:=j and k;'); + Add(' i:=j or k;'); + Add(' i:=j or not k;'); + Add(' i:=(not j) or k;'); + Add(' i:=j or false;'); + Add(' i:=j and true;'); + ParseProgram; +end; + +procedure TTestResolver.TestStringOperators; +begin + StartProgram(false); + Add('var'); + Add(' i,j:string;'); + Add(' k:char;'); + Add('begin'); + Add(' i:='''';'); + Add(' i:=''''+'''';'); + Add(' i:=k+'''';'); + Add(' i:=''''+k;'); + Add(' i:=''a''+j;'); + Add(' i:=''abc''+j;'); + Add(' k:=j;'); + Add(' k:=''a'';'); + ParseProgram; +end; + procedure TTestResolver.TestForLoop; begin StartProgram(false); @@ -1382,7 +1579,8 @@ procedure TTestResolver.TestTryStatement; begin StartProgram(false); Add('type'); - Add(' {#Exec}Exception = longint;'); + Add(' TObject = class end;'); + Add(' {#Exec}Exception = class end;'); Add('var'); Add(' {#v1}v1,{#e1}e:longint;'); Add('begin'); @@ -1399,9 +1597,9 @@ begin Add(' try'); Add(' {@v1}v1:={@e1}e;'); Add(' except'); - Add(' on {#e2}E: {@Exec}Exception do'); + Add(' on {#e2}{=Exec}E: Exception do'); Add(' if {@e2}e=nil then ;'); - Add(' on {#e3}E: {@Exec}Exception do'); + Add(' on {#e3}{=Exec}E: Exception do'); Add(' raise {@e3}e;'); Add(' else'); Add(' {@v1}v1:={@e1}e;'); @@ -1409,6 +1607,101 @@ begin ParseProgram; end; +procedure TTestResolver.TestTryExceptOnNonTypeFail; +var + ok: Boolean; +begin + StartProgram(false); + Add('type TObject = class end;'); + Add('var E: TObject;'); + Add('begin'); + Add(' try'); + Add(' except'); + Add(' on E do ;'); + Add(' end;'); + ok:=false; + try + ParseModule; + except + on E: EParserError do + begin + AssertEquals('Expected "Expected type, but got variable", but got msg number "'+E.Message+'"', + PParser.nParserExpectedTypeButGot,Parser.LastMsgNumber); + ok:=true; + end; + end; + AssertEquals('try..except..on longint do failed',true,ok); +end; + +procedure TTestResolver.TestTryExceptOnNonClassFail; +var + ok: Boolean; +begin + StartProgram(false); + Add('begin'); + Add(' try'); + Add(' except'); + Add(' on longint do ;'); + Add(' end;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected "class expected but longint found", but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('try..except..on longint do failed',true,ok); +end; + +procedure TTestResolver.TestRaiseNonVarFail; +var + ok: Boolean; +begin + StartProgram(false); + Add('type TObject = class end;'); + Add('begin'); + Add(' raise TObject;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected "var expected but type found", but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('raise longint failed',true,ok); +end; + +procedure TTestResolver.TestRaiseNonClassFail; +var + ok: Boolean; +begin + StartProgram(false); + Add('var'); + Add(' E: longint;'); + Add('begin'); + Add(' raise E;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected "class expected but longint found", but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('raise longint failed',true,ok); +end; + procedure TTestResolver.TestStatementsRefs; begin StartProgram(false); @@ -1437,6 +1730,70 @@ begin AssertEquals('3 declarations',3,PasProgram.ProgramSection.Declarations.Count); end; +procedure TTestResolver.TestRepeatUntilNonBoolFail; +var + ok: Boolean; +begin + StartProgram(false); + Add('begin'); + Add(' repeat'); + Add(' until 3;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected boolean expected but longint found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('repeat until condition not boolean spotted',true,ok); +end; + +procedure TTestResolver.TestWhileDoNonBoolFail; +var + ok: Boolean; +begin + StartProgram(false); + Add('begin'); + Add(' while 3 do ;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected boolean expected but longint found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('repeat while do condition not boolean spotted',true,ok); +end; + +procedure TTestResolver.TestIfThenNonBoolFail; +var + ok: Boolean; +begin + StartProgram(false); + Add('begin'); + Add(' if 3 then ;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected boolean expected but longint found, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('if-then condition not boolean spotted',true,ok); +end; + procedure TTestResolver.TestUnitRef; var El, DeclEl, OtherUnit: TPasElement; @@ -1450,8 +1807,8 @@ begin Add('var exitCOde: string;'); Add('implementation'); Add('initialization'); - Add(' ExitcodE:=''3'';'); - Add(' afile.eXitCode:=3;'); + Add(' ExitcodE:=''1'';'); + Add(' afile.eXitCode:=''2'';'); Add(' System.exiTCode:=3;'); ParseUnit; @@ -1934,6 +2291,51 @@ begin AssertEquals('overload proc/var raised an error',true,ok); end; +procedure TTestResolver.TestProcCallMissingParams; +var + ok: Boolean; +begin + StartProgram(false); + Add('procedure Proc1(a: longint);'); + Add('begin'); + Add('end;'); + Add('begin'); + Add(' Proc1;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected Wrong number of parameters for call to "Proc1", but got msg number "'+E.Message+'"', + PasResolver.nWrongNumberOfParametersForCallTo,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('proc call without params raised an error',true,ok); +end; + +procedure TTestResolver.TestBuiltInProcCallMissingParams; +var + ok: Boolean; +begin + StartProgram(false); + Add('begin'); + Add(' length;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected Wrong number of parameters for call to "length", but got msg number "'+E.Message+'"', + PasResolver.nWrongNumberOfParametersForCallTo,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('proc call without params raised an error',true,ok); +end; + procedure TTestResolver.TestRecord; begin StartProgram(false); @@ -2075,7 +2477,7 @@ 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;'); + Add(' {@V}v.{@A_b}b.{@B_a}a:=3;'); ParseProgram; end; @@ -2335,6 +2737,32 @@ begin ParseProgram; end; +procedure TTestResolver.TestClassOverride2; +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(' {#B}TClassB = class'); + Add(' procedure {#B_ProcA}ProcA; override;'); + Add(' end;'); + Add('procedure TClassA.ProcA;'); + Add('begin'); + Add('end;'); + Add('procedure TClassB.ProcA;'); + Add('begin'); + Add('end;'); + Add('var'); + Add(' {#V}{=B}v: TClassB;'); + Add('begin'); + Add(' {@V}v.{@B_ProcA}ProcA;'); + ParseProgram; +end; + procedure TTestResolver.TestClassMethodScope; begin StartProgram(false); @@ -2379,12 +2807,12 @@ begin StartProgram(false); Add('type'); Add(' TObject = class'); - Add(' procedure {#TOBJ_ProcA}ProcA(i: longint);'); - Add(' procedure {#TOBJ_ProcB}ProcB(j: longint);'); + Add(' procedure {#TOBJ_ProcA}ProcA(i: longint); virtual;'); + Add(' procedure {#TOBJ_ProcB}ProcB(j: longint); virtual;'); Add(' end;'); Add(' {#A}TClassA = class'); - Add(' procedure {#A_ProcA}ProcA(i: longint);'); - Add(' procedure {#A_ProcB}ProcB(k: longint);'); + Add(' procedure {#A_ProcA}ProcA(i: longint); override;'); + Add(' procedure {#A_ProcB}ProcB(j: longint); override;'); Add(' end;'); Add('procedure TObject.ProcA(i: longint);'); Add('begin'); @@ -2395,19 +2823,289 @@ begin Add('end;'); Add('procedure TClassA.ProcA({#i1}i: longint);'); Add('begin'); - Add(' {@A_ProcA}ProcA;'); + Add(' {@A_ProcA}ProcA({@i1}i);'); Add(' {@TOBJ_ProcA}inherited;'); Add(' inherited {@TOBJ_ProcA}ProcA({@i1}i);'); - Add(' {@A_ProcB}ProcB;'); + Add(' {@A_ProcB}ProcB({@i1}i);'); Add(' inherited {@TOBJ_ProcB}ProcB({@i1}i);'); Add('end;'); - Add('procedure TClassA.ProcB(k: longint);'); + Add('procedure TClassA.ProcB(j: longint);'); Add('begin'); Add('end;'); Add('begin'); ParseProgram; end; +procedure TTestResolver.TestClassCallInheritedNoParamsAbstractFail; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure ProcA; virtual; abstract;'); + Add(' end;'); + Add(' TClassA = class'); + Add(' procedure ProcA; override;'); + Add(' end;'); + Add('procedure TClassA.ProcA;'); + Add('begin'); + Add(' inherited;'); + Add('end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected Abstract methods cannot be called directly, but got msg number "'+E.Message+'"', + PasResolver.nAbstractMethodsCannotBeCalledDirectly,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('inherited without parameters calling abstract method fails',true,ok); +end; + +procedure TTestResolver.TestClassCallInheritedWithParamsAbstractFail; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure ProcA(c: char); virtual; abstract;'); + Add(' end;'); + Add(' TClassA = class'); + Add(' procedure ProcA(c: char); override;'); + Add(' end;'); + Add('procedure TClassA.ProcA(c: char);'); + Add('begin'); + Add(' inherited ProcA(c);'); + Add('end;'); + Add('begin'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected Abstract methods cannot be called directly, but got msg number "'+E.Message+'"', + PasResolver.nAbstractMethodsCannotBeCalledDirectly,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('inherited without parameters calling abstract method fails',true,ok); +end; + +procedure TTestResolver.TestClassAssignNil; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' {#FSub}FSub: TClassA;'); + Add(' property {#Sub}Sub: TClassA read {@FSub}FSub write {@FSub}FSub;'); + Add(' end;'); + Add('var'); + Add(' {#v}{=A}v: TClassA;'); + Add('begin'); + Add(' {@v}v:=nil;'); + Add(' if {@v}v=nil then ;'); + Add(' if {@v}v<>nil then ;'); + Add(' {@v}v.{@FSub}FSub:=nil;'); + Add(' if {@v}v.{@FSub}FSub=nil then ;'); + Add(' if {@v}v.{@FSub}FSub<>nil then ;'); + Add(' {@v}v.{@Sub}Sub:=nil;'); + Add(' if {@v}v.{@Sub}Sub=nil then ;'); + Add(' if {@v}v.{@Sub}Sub<>nil then ;'); + ParseProgram; +end; + +procedure TTestResolver.TestClassAssign; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' {#FSub}FSub: TClassA;'); + Add(' property {#Sub}Sub: TClassA read {@FSub}FSub write {@FSub}FSub;'); + Add(' end;'); + Add('var'); + Add(' {#o}{=TOBJ}o: TObject;'); + Add(' {#v}{=A}v: TClassA;'); + Add(' {#p}{=A}p: TClassA;'); + Add('begin'); + Add(' {@o}o:={@v}v;'); + Add(' {@v}v:={@p}p;'); + Add(' if {@v}v={@p}p then ;'); + Add(' if {@v}v={@o}o then ;'); + Add(' if {@o}o={@o}o then ;'); + Add(' if {@o}o={@v}v then ;'); + Add(' if {@v}v<>{@p}p then ;'); + Add(' if {@v}v<>{@o}o then ;'); + Add(' if {@o}o<>{@o}o then ;'); + Add(' if {@o}o<>{@v}v then ;'); + Add(' {@v}v.{@FSub}FSub:={@p}p;'); + Add(' {@p}p:={@v}v.{@FSub}FSub;'); + Add(' {@o}o:={@v}v.{@FSub}FSub;'); + Add(' {@v}v.{@Sub}Sub:={@p}p;'); + Add(' {@p}p:={@v}v.{@Sub}Sub;'); + Add(' {@o}o:={@v}v.{@Sub}Sub;'); + ParseProgram; +end; + +procedure TTestResolver.TestClassNilAsParam; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' end;'); + Add('procedure ProcP(o: TObject);'); + Add('begin end;'); + Add('begin'); + Add(' ProcP(nil);'); + ParseProgram; +end; + +procedure TTestResolver.TestClassOperator_Is_As; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' {#Sub}Sub: TClassA;'); + Add(' end;'); + Add('var'); + Add(' {#o}{=TOBJ}o: TObject;'); + Add(' {#v}{=A}v: TClassA;'); + Add('begin'); + Add(' if {@o}o is {@A}TClassA then;'); + Add(' if {@v}v is {@A}TClassA then;'); + Add(' if {@v}v.{@Sub}Sub is {@A}TClassA then;'); + Add(' {@v}v:={@o}o as {@A}TClassA;'); + ParseProgram; +end; + +procedure TTestResolver.TestClassOperatorIsOnNonDescendantFail; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' end;'); + Add('var'); + Add(' {#o}{=TOBJ}o: TObject;'); + Add(' {#v}{=A}v: TClassA;'); + Add('begin'); + Add(' if {@v}v is {@TObj}TObject then;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected types are not related, but got msg number "'+E.Message+'"', + PasResolver.nTypesAreNotRelated,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('operator "is" requires descendant',true,ok); +end; + +procedure TTestResolver.TestClassOperatorIsOnNonTypeFail; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' end;'); + Add('var'); + Add(' {#o}{=TOBJ}o: TObject;'); + Add(' {#v}{=A}v: TClassA;'); + Add('begin'); + Add(' if {@o}o is {@v}v then;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected class type expected, but got variable, but got msg number "'+E.Message+'"', + PasResolver.nXExpectedButYFound,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('operator "is" requires descendant type',true,ok); +end; + +procedure TTestResolver.TestClassOperatorAsOnNonDescendantFail; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' end;'); + Add('var'); + Add(' {#o}{=TOBJ}o: TObject;'); + Add(' {#v}{=A}v: TClassA;'); + Add('begin'); + Add(' {@o}o:={@v}v as {@TObj}TObject;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected types are not related, but got msg number "'+E.Message+'"', + PasResolver.nTypesAreNotRelated,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('operator "as" requires descendant',true,ok); +end; + +procedure TTestResolver.TestClassOperatorAsOnNonTypeFail; +var + ok: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' end;'); + Add(' {#A}TClassA = class'); + Add(' end;'); + Add('var'); + Add(' {#o}{=TOBJ}o: TObject;'); + Add(' {#v}{=A}v: TClassA;'); + Add('begin'); + Add(' {@o}o:={@v}v as {@o}o;'); + ok:=false; + try + ParseModule; + except + on E: EPasResolve do + begin + AssertEquals('Expected types are not related, but got msg number "'+E.Message+'"', + PasResolver.nTypesAreNotRelated,E.MsgNumber); + ok:=true; + end; + end; + AssertEquals('operator "as" requires descendant type',true,ok); +end; + procedure TTestResolver.TestProperty1; begin StartProgram(false); @@ -2564,7 +3262,7 @@ begin Add('var'); Add(' {#o}{=TOBJ}o: TObject;'); Add('begin'); - Add(' {@o}o.{@B}B:=3;'); + Add(' if {@o}o.{@B}B=3 then ;'); ParseProgram; end; @@ -2717,11 +3415,11 @@ begin Add('type'); Add(' {#TOBJ}TObject = class'); Add(' {#FB}FB: longint;'); - Add(' property {#TOBJ_B}B: longint read {@FB}FB;'); + Add(' property {#TOBJ_B}B: longint write {@FB}FB;'); Add(' end;'); Add(' {#TA}TClassA = class'); Add(' {#FC}FC: longint;'); - Add(' property {#TA_B}{@TOBJ_B}B read {@FC}FC;'); + Add(' property {#TA_B}{@TOBJ_B}B write {@FC}FC;'); Add(' end;'); Add('var'); Add(' {#v}{=TA}v: TClassA;'); @@ -2855,6 +3553,66 @@ begin ParseProgram; end; +procedure TTestResolver.TestWithBlock1; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' {#TOBJ_A}A: longint;'); + Add(' end;'); + Add('var'); + Add(' {#o}{=TOBJ}o: TObject;'); + Add(' {#a}a: longint;'); + Add('begin'); + Add(' {@a}a:=1;'); + Add(' with {@o}o do'); + Add(' {@TOBJ_A}a:=2;'); + ParseProgram; +end; + +procedure TTestResolver.TestWithBlock2; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' {#TOBJ_i}i: longint;'); + Add(' end;'); + Add(' {#TA}TClassA = class'); + Add(' {#TA_j}j: longint;'); + Add(' {#TA_b}{=TA}b: TClassA;'); + Add(' end;'); + Add('var'); + Add(' {#o}{=TOBJ}o: TObject;'); + Add(' {#a}{=TA}a: TClassA;'); + Add(' {#i}i: longint;'); + Add('begin'); + Add(' {@i}i:=1;'); + Add(' with {@o}o do'); + Add(' {@TOBJ_i}i:=2;'); + Add(' {@i}i:=1;'); + Add(' with {@o}o,{@a}a do begin'); + Add(' {@TOBJ_i}i:=3;'); + Add(' {@TA_j}j:=4;'); + Add(' {@TA_b}b:={@a}a;'); + Add(' end;'); + ParseProgram; +end; + +procedure TTestResolver.TestDynArrayOfLongint; +begin + Exit; + + StartProgram(false); + Add('type TIntArray = array of longint;'); + Add('var a: TIntArray;'); + Add('begin'); + Add(' SetLength(a,3);'); + Add(' a[0]:=1;'); + Add(' a[1]:=length(a);'); + Add(' a[2]:=a[0];'); + ParseProgram; +end; + initialization RegisterTests([TTestResolver]); diff --git a/packages/fcl-passrc/tests/tcstatements.pas b/packages/fcl-passrc/tests/tcstatements.pas index abd14033dc..96d5563527 100644 --- a/packages/fcl-passrc/tests/tcstatements.pas +++ b/packages/fcl-passrc/tests/tcstatements.pas @@ -1326,8 +1326,8 @@ begin O:=TPasImplExceptOn(E.Elements[0]); AssertEquals(1,O.Elements.Count); AssertEquals('Simple statement',TPasImplSimple,TPasElement(O.Elements[0]).ClassType); - AssertExpression('Exception Variable name',O.VarExpr,pekIdent,'E'); - AssertExpression('Exception Type name',O.TypeExpr,pekIdent,'Exception'); + AssertEquals('Exception Variable name','E',O.VariableName); + AssertEquals('Exception Type name','Exception',O.TypeName); S:=TPasImplSimple(O.Elements[0]); AssertExpression('DoSomethingElse call',S.Expr,pekIdent,'DoSomethingElse'); // AssertEquals('Variable name', @@ -1364,8 +1364,8 @@ begin O:=TPasImplExceptOn(E.Elements[0]); AssertEquals(1,O.Elements.Count); AssertEquals('Simple statement',TPasImplSimple,TPasElement(O.Elements[0]).ClassType); - AssertExpression('Exception Variable name',O.VarExpr,pekIdent,'E'); - AssertExpression('Exception Type name',O.TypeExpr,pekIdent,'Exception'); + AssertEquals('Exception Variable name','E',O.VariableName); + AssertEquals('Exception Type name','Exception',O.TypeName); S:=TPasImplSimple(O.Elements[0]); AssertExpression('DoSomethingElse call',S.Expr,pekIdent,'DoSomethingElse'); // Exception handler 2 @@ -1373,8 +1373,8 @@ begin O:=TPasImplExceptOn(E.Elements[1]); AssertEquals(1,O.Elements.Count); AssertEquals('Simple statement',TPasImplSimple,TPasElement(O.Elements[0]).ClassType); - AssertExpression('Exception Variable name',O.VarExpr,pekIdent,'Y'); - AssertExpression('Exception Type name',O.TypeExpr,pekIdent,'Exception2'); + AssertEquals('Exception Variable name','Y',O.VariableName); + AssertEquals('Exception Type name','Exception2',O.TypeName); S:=TPasImplSimple(O.Elements[0]); AssertExpression('DoSomethingElse call',S.Expr,pekIdent,'DoSomethingElse2'); end; @@ -1407,8 +1407,8 @@ begin AssertEquals(1,E.Elements.Count); AssertEquals('Except on handler',TPasImplExceptOn,TPasElement(E.Elements[0]).ClassType); O:=TPasImplExceptOn(E.Elements[0]); - AssertExpression('Exception Variable name',O.VarExpr,pekIdent,'E'); - AssertExpression('Exception Type name',O.TypeExpr,pekIdent,'Exception'); + AssertEquals('Exception Variable name','E',O.VariableName); + AssertEquals('Exception Type name','Exception',O.TypeName); AssertEquals(1,O.Elements.Count); AssertEquals('Simple statement',TPasImplIfElse,TPasElement(O.Elements[0]).ClassType); I:=TPasImplIfElse(O.Elements[0]); @@ -1450,8 +1450,8 @@ begin AssertEquals(1,E.Elements.Count); AssertEquals('Except on handler',TPasImplExceptOn,TPasElement(E.Elements[0]).ClassType); O:=TPasImplExceptOn(E.Elements[0]); - AssertExpression('Exception Variable name',O.VarExpr,pekIdent,'E'); - AssertExpression('Exception Type name',O.TypeExpr,pekIdent,'Exception'); + AssertEquals('Exception Variable name','E',O.VariableName); + AssertEquals('Exception Type name','Exception',O.TypeName); AssertEquals(1,O.Elements.Count); AssertEquals('Simple statement',TPasImplSimple,TPasElement(O.Elements[0]).ClassType); S:=TPasImplSimple(O.Elements[0]); diff --git a/packages/pastojs/tests/tcconverter.pp b/packages/pastojs/tests/tcconverter.pp index 9bf3c7abf4..21239e3a26 100644 --- a/packages/pastojs/tests/tcconverter.pp +++ b/packages/pastojs/tests/tcconverter.pp @@ -644,7 +644,7 @@ begin T:=TPasImplTry.Create('',Nil); T.AddElement(CreateAssignStatement('a','b')); F:=T.AddExcept; - O:=F.AddExceptOn(CreateIdent('E'),CreateIdent('Exception')); + O:=F.AddExceptOn('E','Exception'); O.Body:=CreateAssignStatement('b','c'); // Convert El:=TJSTryFinallyStatement(Convert(T,TJSTryCatchStatement)); @@ -692,7 +692,7 @@ begin T:=TPasImplTry.Create('',Nil); T.AddElement(CreateAssignStatement('a','b')); F:=T.AddExcept; - O:=F.AddExceptOn(CreateIdent('E'),CreateIdent('Exception')); + O:=F.AddExceptOn('E','Exception'); O.Body:=TPasImplRaise.Create('',Nil); // Convert El:=TJSTryFinallyStatement(Convert(T,TJSTryCatchStatement));