{ *************************************************************************** * * * This source is free software; you can redistribute it and/or modify * * it under the terms of the GNU General Public License as published by * * the Free Software Foundation; either version 2 of the License, or * * (at your option) any later version. * * * * This code is distributed in the hope that it will be useful, but * * WITHOUT ANY WARRANTY; without even the implied warranty of * * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * * General Public License for more details. * * * * A copy of the GNU General Public License is available on the World * * Wide Web at . You can also * * obtain it by writing to the Free Software Foundation, * * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. * * * *************************************************************************** Author: Mattias Gaertner Abstract: TFindDeclarationTool enhances the TPascalReaderTool with the ability to find the source position or code tree node of a declaration. ToDo: - find declaration in dead code (started) - high type expression evaluation (i.e. at the moment: integer+integer=longint wanted: integer+integer=integer) - multi pass find declaration (i.e. searching with timeout) - Get and Set property access parameter lists - make @Proc context sensitive (started, but not complete) - operator overloading - ppu, ppw, dcu files - many things, search for 'ToDo' } unit FindDeclarationTool; {$ifdef FPC}{$mode objfpc}{$endif}{$H+} interface {$I codetools.inc} // activate for debugging: // mem check { $DEFINE MEM_CHECK} // verbosity { $DEFINE CTDEBUG} { $DEFINE ShowTriedFiles} { $DEFINE ShowTriedContexts} { $DEFINE ShowTriedBaseContexts} { $DEFINE ShowTriedParentContexts} { $DEFINE ShowTriedIdentifiers} { $DEFINE ShowTriedUnits} { $DEFINE ShowExprEval} { $DEFINE ShowFoundIdentifier} { $DEFINE ShowInterfaceCache} { $DEFINE ShowNodeCache} { $DEFINE ShowBaseTypeCache} { $DEFINE ShowCacheDependencies} { $DEFINE ShowCollect} { $DEFINE ShowProcSearch} { $DEFINE DebugAddToolDependency} {$IFDEF CTDEBUG}{$DEFINE DebugPrefix}{$ENDIF} {$IFDEF ShowTriedIdentifiers}{$DEFINE DebugPrefix}{$ENDIF} {$IFDEF ShowTriedContexts}{$DEFINE DebugPrefix}{$ENDIF} // new features { $DEFINE DisableIgnoreErrorAfter} uses {$IFDEF MEM_CHECK} MemCheck, {$ENDIF} Classes, SysUtils, CodeToolsStrConsts, CodeTree, CodeAtom, CustomCodeTool, SourceLog, KeywordFuncLists, BasicCodeTools, LinkScanner, CodeCache, DirectoryCacher, AVL_Tree, PascalParserTool, PascalReaderTool, FileProcs, DefineTemplates, FindDeclarationCache; type TFindDeclarationTool = class; //---------------------------------------------------------------------------- // variable atoms TVariableAtomType = ( vatNone, // undefined vatSpace, // empty or space vatIdentifier, // an identifier vatPreDefIdentifier, // an identifier with special meaning to the compiler vatPoint, // . vatAS, // AS keyword vatINHERITED, // INHERITED keyword vatUp, // ^ vatRoundBracketOpen, // ( vatRoundBracketClose,// ) vatEdgedBracketOpen, // [ vatEdgedBracketClose,// ] vatAddrOp, // @ vatKeyword // other keywords ); const // for nicer debugging output VariableAtomTypeNames: array[TVariableAtomType] of string = ('', 'Space', 'Ident', 'PreDefIdent', 'Point', 'AS', 'INHERITED', 'Up^ ', 'Bracket(', 'Bracket)', 'Bracket[', 'Bracket]', 'AddrOperator@ ', 'Keyword' ); type //---------------------------------------------------------------------------- // searchpath delimiter is semicolon TOnGetSearchPath = function(Sender: TObject): string of object; TOnGetSrcPathForCompiledUnit = function(Sender: TObject; const Filename: string): string of object; //---------------------------------------------------------------------------- TOnGetMethodname = function(const AMethod: TMethod; CheckOwner: TObject): string of object; //---------------------------------------------------------------------------- // flags/states for searching TFindDeclarationFlag = ( fdfSearchInAncestors, // if context is a class, search also in // ancestors/interfaces fdfSearchInParentNodes, // if identifier not found in current context, // proceed in prior nodes on same lvl and parents fdfIgnoreCurContextNode,// skip context and proceed in prior/parent context fdfIgnoreUsedUnits, // stay in current source fdfSearchForward, // instead of searching in prior nodes, search in // next nodes (successors) fdfExceptionOnNotFound, // raise exception if identifier not found // predefined identifiers will not raise fdfExceptionOnPredefinedIdent,// raise an exception even if the identifier // is an predefined identifier fdfIgnoreClassVisibility,//find inaccessible private+protected fields fdfIgnoreMissingParams, // found proc fits, even if parameters are missing fdfOnlyCompatibleProc, // incompatible procs are ignored fdfIgnoreOverloadedProcs,// ignore param lists and take the first proc found fdfFindVariable, // do not search for the base type of a variable, // instead return the variable declaration fdfFunctionResult, // if function is found, return result type fdfEnumIdentifier, // do not resolve enum to its enum type fdfFindChilds, // search the class of a 'class of' fdfSkipClassForward, // when a class forward was found search the class fdfCollect, // return every reachable identifier fdfTopLvlResolving, // set, when searching for an identifier of the // top lvl variable fdfDoNotCache // result will not be cached ); TFindDeclarationFlags = set of TFindDeclarationFlag; const fdfGlobals = [fdfExceptionOnNotFound, fdfTopLvlResolving]; fdfGlobalsSameIdent = fdfGlobals+[fdfExceptionOnPredefinedIdent, fdfIgnoreMissingParams, fdfIgnoreUsedUnits, fdfDoNotCache, fdfOnlyCompatibleProc, fdfSearchInAncestors, fdfCollect]; fdfDefaultForExpressions = [fdfSearchInParentNodes, fdfSearchInAncestors, fdfExceptionOnNotFound]; // for nicer output FindDeclarationFlagNames: array[TFindDeclarationFlag] of string = ( 'fdfSearchInAncestors', 'fdfSearchInParentNodes', 'fdfIgnoreCurContextNode', 'fdfIgnoreUsedUnits', 'fdfSearchForward', 'fdfExceptionOnNotFound', 'fdfExceptionOnPredefinedIdent', 'fdfIgnoreClassVisibility', 'fdfIgnoreMissingParams', 'fdfOnlyCompatibleProc', 'fdfIgnoreOverloadedProcs', 'fdfFindVariable', 'fdfFunctionResult', 'fdfEnumIdentifier', 'fdfFindChilds', 'fdfSkipClassForward', 'fdfCollect', 'fdfTopLvlResolving', 'fdfDoNotCache' ); type // flags/states for result TFoundDeclarationFlag = ( fodDoNotCache ); TFoundDeclarationFlags = set of TFoundDeclarationFlag; const FoundDeclarationFlagNames: array[TFoundDeclarationFlag] of string = ( 'fodDoNotCache' ); //---------------------------------------------------------------------------- type TFindDeclarationParams = class; TFindContext = record Node: TCodeTreeNode; Tool: TFindDeclarationTool; end; PFindContext = ^TFindContext; const CleanFindContext: TFindContext = (Node:nil; Tool:nil); type //---------------------------------------------------------------------------- { TExpressionTypeDesc describes predefined types The Freepascal compiler can automatically convert them } TExpressionTypeDesc = ( xtNone, // undefined xtContext, // a node xtChar, // char xtWideChar, // widechar xtReal, // real xtSingle, // single xtDouble, // double xtExtended, // extended xtCurrency, // currency xtComp, // comp xtInt64, // int64 xtCardinal, // cardinal xtQWord, // qword xtBoolean, // boolean xtByteBool, // bytebool xtWordBool, // wordbool xtLongBool, // longbool xtQWordBool, // qwordbool xtString, // string xtAnsiString, // ansistring xtShortString, // shortstring xtWideString, // widestring xtUnicodeString,// unicodestring xtPChar, // pchar xtPointer, // pointer xtFile, // file xtText, // text xtConstOrdInteger,// enum, number, integer xtConstString, // string, string constant, char constant xtConstReal, // real number xtConstSet, // [] set xtConstBoolean,// true, false xtLongint, // longint xtLongWord, // longword xtWord, // word xtSmallInt, // smallint xtShortInt, // shortint xtByte, // byte xtCompilerFunc,// SUCC, PREC, LOW, HIGH, ORD, LENGTH, COPY (1.1) xtVariant, // variant xtNil // nil = pointer, class, procedure, method, ... ); // Do not use this: TExpressionTypeDescs = set of TExpressionTypeDesc; // There are too many enums, so the set would be big and slow const ExpressionTypeDescNames: array[TExpressionTypeDesc] of string = ( 'None', 'Context', 'Char', 'WideChar', 'Real', 'Single', 'Double', 'Extended', 'Currency', 'Comp', 'Int64', 'Cardinal', 'QWord', 'Boolean', 'ByteBool', 'WordBool', 'LongBool', 'QWordBool', 'String', 'AnsiString', 'ShortString', 'WideString', 'UnicodeString', 'PChar', 'Pointer', 'File', 'TextFile', 'ConstOrdInt', 'ConstString', 'ConstReal', 'ConstSet', 'ConstBoolean', 'LongInt', 'LongWord', 'Word', 'SmallInt', 'ShortInt', 'Byte', 'CompilerFunc', 'Variant', 'Nil' ); xtAllTypes = [Low(TExpressionTypeDesc)..High(TExpressionTypeDesc)]-[xtNone]; xtAllPredefinedTypes = xtAllTypes-[xtContext]; xtAllIntegerTypes = [xtInt64, xtQWord, xtConstOrdInteger, xtLongint, xtLongWord, xtWord, xtCardinal, xtSmallInt, xtShortInt, xtByte]; xtAllBooleanTypes = [xtBoolean, xtByteBool, xtWordBool, xtLongBool,xtQWordBool]; xtAllRealTypes = [xtReal, xtConstReal, xtSingle, xtDouble, xtExtended, xtCurrency, xtComp]; xtAllStringTypes = [xtConstString, xtShortString, xtString, xtAnsiString]; xtAllWideStringTypes = [xtConstString, xtWideString, xtUnicodeString]; xtAllPointerTypes = [xtPointer, xtNil]; xtAllStringCompatibleTypes = xtAllStringTypes+[xtChar]; xtAllWideStringCompatibleTypes = xtAllWideStringTypes+[xtWideChar,xtChar]; xtAllIntegerConvertibles = xtAllIntegerTypes; xtAllRealConvertibles = xtAllRealTypes+xtAllIntegerTypes; xtAllStringConvertibles = xtAllStringCompatibleTypes+[xtPChar]; xtAllWideStringConvertibles = xtAllWideStringCompatibleTypes+[xtPChar]; xtAllBooleanConvertibles = xtAllBooleanTypes+[xtConstBoolean]; xtAllPointerConvertibles = xtAllPointerTypes+[xtPChar]; type { TExpressionType is used for compatibility check A compatibility check is done by comparing two TExpressionType if Desc = xtConstSet, SubDesc contains the type of the set if Context.Node<>nil, it contains the corresponding codetree node if Desc = xtPointer then SubDesc contains the type e.g. xtChar } TExpressionType = record Desc: TExpressionTypeDesc; SubDesc: TExpressionTypeDesc; Context: TFindContext; end; PExpressionType = ^TExpressionType; const CleanExpressionType : TExpressionType = (Desc:xtNone; SubDesc:xtNone; Context:(Node:nil; Tool:nil)); type //---------------------------------------------------------------------------- // TTypeCompatibility is the result of a compatibility check TTypeCompatibility = ( tcExact, // exactly same type tcCompatible, // type can be auto converted tcIncompatible // type is incompatible ); TTypeCompatibilityList = ^TTypeCompatibility; const TypeCompatibilityNames: array[TTypeCompatibility] of string = ( 'Exact', 'Compatible', // convertable, but not allowed for var params 'Incompatible' ); type //---------------------------------------------------------------------------- // TExprTypeList is used for compatibility checks of whole parameter lists TExprTypeList = class private FCapacity: integer; procedure SetCapacity(const AValue: integer); protected procedure Grow; public Count: integer; Items: ^TExpressionType; procedure Add(const ExprType: TExpressionType); procedure AddFirst(const ExprType: TExpressionType); property Capacity: integer read FCapacity write SetCapacity; destructor Destroy; override; function AsString: string; function CalcMemSize: PtrUInt; end; //---------------------------------------------------------------------------- // TFoundProc is used for comparing overloaded procs PFoundProc = ^TFoundProc; TFoundProc = record // the expression input list, which should fit into the searched proc ExprInputList: TExprTypeList; // the best proc found till now Context: TFindContext; // if the proc was already compared (CacheValid=true), then some of the // compatibility check results are cached. CacheValid: boolean; ProcCompatibility: TTypeCompatibility; ParamCompatibilityList: TTypeCompatibilityList; // each TFindDeclarationParams has a list of PFoundProc Owner: TObject; Next, Prior: PFoundProc; end; //--------------------------------------------------------------------------- type TIdentifierFoundResult = (ifrProceedSearch, ifrAbortSearch, ifrSuccess); const IdentifierFoundResultNames: array[TIdentifierFoundResult] of shortstring = ('ProceedSearch', 'AbortSearch', 'Success'); type TOnIdentifierFound = function(Params: TFindDeclarationParams; const FoundContext: TFindContext): TIdentifierFoundResult of object; TOnFindUsedUnit = function(SrcTool: TFindDeclarationTool; const TheUnitName, TheUnitInFilename: string): TCodeBuffer of object; TOnGetCodeToolForBuffer = function(Sender: TObject; Code: TCodeBuffer; GoToMainCode: boolean): TFindDeclarationTool of object; TOnGetDirectoryCache = function(const ADirectory: string ): TCTDirectoryCache of object; TFindDeclarationInput = record Flags: TFindDeclarationFlags; Identifier: PChar; ContextNode: TCodeTreeNode; OnIdentifierFound: TOnIdentifierFound; IdentifierTool: TFindDeclarationTool; FoundProc: PFoundProc; end; { TFindDeclarationParams This contains the parameters for find declaration, the result, the hooks and the memory management for dynamic search data. It can be re-used. That means, the search parameters can be saved, changed and restored (load). The static parameters are stored on the stack, while the dynamic data (e.g. FoundProc) is stored in a private list (FirstFoundProc). For speed reasons the find declaration does not use try..finally and that's why some saved data is not explicitely freed. Therefore the Load method frees all dynamic data, that was later saved too. That's why the following code is forbidden: Save(Data1); Save(Data2); Load(Data1); // this will free Data2 Load(Data2); When searching a procedure, the parameter list must be compared. The parameter list of the currently best fitting procedure is stored in FoundProc. } TFindDeclarationParams = class(TObject) private FirstFoundProc: PFoundProc;//list of all saved PFoundProc LastFoundProc: PFoundProc; procedure FreeFoundProc(aFoundProc: PFoundProc; FreeNext: boolean); procedure RemoveFoundProcFromList(aFoundProc: PFoundProc); public // input parameters: Flags: TFindDeclarationFlags; Identifier: PChar; ContextNode: TCodeTreeNode; OnIdentifierFound: TOnIdentifierFound; IdentifierTool: TFindDeclarationTool; FoundProc: PFoundProc; Data: Pointer; // global params OnTopLvlIdentifierFound: TOnIdentifierFound; // results: NewNode: TCodeTreeNode; NewCleanPos: integer; NewCodeTool: TFindDeclarationTool; NewPos: TCodeXYPosition; NewTopLine: integer; NewFlags: TFoundDeclarationFlags; constructor Create; destructor Destroy; override; procedure Clear; procedure Save(out Input: TFindDeclarationInput); procedure Load(Input: TFindDeclarationInput; FreeInput: boolean); procedure SetResult(const AFindContext: TFindContext); procedure SetResult(ANewCodeTool: TFindDeclarationTool; ANewNode: TCodeTreeNode); procedure SetResult(ANewCodeTool: TFindDeclarationTool; ANewNode: TCodeTreeNode; ANewCleanPos: integer); procedure SetResult(NodeCacheEntry: PCodeTreeNodeCacheEntry); procedure SetIdentifier(NewIdentifierTool: TFindDeclarationTool; NewIdentifier: PChar; NewOnIdentifierFound: TOnIdentifierFound); procedure SetFirstFoundProc(const ProcContext: TFindContext); procedure ChangeFoundProc(const ProcContext: TFindContext; ProcCompatibility: TTypeCompatibility; ParamCompatibilityList: TTypeCompatibilityList); function IsFinal: boolean; procedure PrettifyResult; procedure ConvertResultCleanPosToCaretPos; procedure ClearResult(CopyCacheFlags: boolean); procedure ClearInput; procedure ClearFoundProc; procedure WriteDebugReport; end; //---------------------------------------------------------------------------- // TFindDeclarationTool is source based and can therefore search for more // than declarations: TFindSmartFlag = ( fsfIncludeDirective, // search for include file fsfFindMainDeclaration, // stop if already on a declaration fsfSearchSourceName, // if searching for a unit name, return the source name node fsfSkipClassForward // when a forward class was found, jump further to the class ); TFindSmartFlags = set of TFindSmartFlag; TFindSrcStartType = ( fsstIdentifier ); TFindDeclarationListFlag = ( fdlfWithoutEmptyProperties, // omit properties without type and attributes fdlfWithoutForwards, // omit foward classes and procedures fdlfIfStartIsDefinitionStop // omit overloads when start is a definition ); TFindDeclarationListFlags = set of TFindDeclarationListFlag; TFindOperatorEnumerator = ( foeProcNode, // proc node of operator foeResultClassNode, // classnode of result type of operator foeEnumeratorCurrentNode, // function or property with modifier 'enumerator Current' foeEnumeratorCurrentExprType // expression type of 'enumerator Current' ); const DefaultFindSmartFlags = [fsfIncludeDirective]; type //---------------------------------------------------------------------------- ECodeToolUnitNotFound = class(ECodeToolFileNotFound) end; //---------------------------------------------------------------------------- { TFindDeclarationTool } TFindDeclarationTool = class(TPascalReaderTool) private FAdjustTopLineDueToComment: boolean; FDirectoryCache: TCTDirectoryCache; FInterfaceIdentifierCache: TInterfaceIdentifierCache; FOnFindUsedUnit: TOnFindUsedUnit; FOnGetCodeToolForBuffer: TOnGetCodeToolForBuffer; FOnGetDirectoryCache: TOnGetDirectoryCache; FOnGetMethodName: TOnGetMethodname; FOnGetSrcPathForCompiledUnit: TOnGetSrcPathForCompiledUnit; FOnGetUnitSourceSearchPath: TOnGetSearchPath; FFirstNodeCache: TCodeTreeNodeCache; FLastNodeCachesGlobalWriteLockStep: integer; FRootNodeCache: TCodeTreeNodeCache; FFirstBaseTypeCache: TBaseTypeCache; FDependentCodeTools: TAVLTree;// the codetools, that depend on this codetool FDependsOnCodeTools: TAVLTree;// the codetools, that this codetool depends on FClearingDependentNodeCaches: boolean; FCheckingNodeCacheDependencies: boolean; {$IFDEF DebugPrefix} DebugPrefix: string; procedure IncPrefix; procedure DecPrefix; {$ENDIF} function FindDeclarationInUsesSection(UsesNode: TCodeTreeNode; CleanPos: integer; out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean; function IsIncludeDirectiveAtPos(CleanPos, CleanCodePosInFront: integer; var IncludeCode: TCodeBuffer): boolean; function FindEnumInContext(Params: TFindDeclarationParams): boolean; // sub methods for FindIdentifierInContext function DoOnIdentifierFound(Params: TFindDeclarationParams; FoundNode: TCodeTreeNode): TIdentifierFoundResult; function FindIdentifierInProcContext(ProcContextNode: TCodeTreeNode; Params: TFindDeclarationParams): TIdentifierFoundResult; function FindIdentifierInClassOfMethod(ProcContextNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean; function FindIdentifierInWithVarContext(WithVarNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean; function FindIdentifierInAncestors(ClassNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean; function FindIdentifierInUsesSection(UsesNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean; function FindIdentifierInHiddenUsedUnits( Params: TFindDeclarationParams): boolean; function FindIdentifierInUsedUnit(const AnUnitName: string; Params: TFindDeclarationParams): boolean; function FindIdentifierInRecordCase(RecordCaseNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean; protected WordIsPredefinedIdentifier: TKeyWordFunctionList; procedure RaiseUsesExpected; procedure RaiseStrConstExpected; protected // node caches procedure DoDeleteNodes; override; function NodeCacheGlobalWriteLockStepDidNotChange: boolean; function CheckDependsOnNodeCaches(CheckedTools: TAVLTree = nil): boolean; procedure ClearNodeCaches(Force: boolean); procedure ClearDependentNodeCaches; procedure ClearDependsOnToolRelationships; procedure AddToolDependency(DependOnTool: TFindDeclarationTool); function CreateNewNodeCache(Node: TCodeTreeNode): TCodeTreeNodeCache; function CreateNewBaseTypeCache(Node: TCodeTreeNode): TBaseTypeCache; procedure CreateBaseTypeCaches(NodeStack: PCodeTreeNodeStack; const Result: TFindContext); function GetNodeCache(Node: TCodeTreeNode; CreateIfNotExists: boolean): TCodeTreeNodeCache; procedure AddResultToNodeCaches( StartNode, EndNode: TCodeTreeNode; SearchedForward: boolean; Params: TFindDeclarationParams; SearchRangeFlags: TNodeCacheEntryFlags); protected // expressions, operands, variables function GetCurrentAtomType: TVariableAtomType; function FindEndOfTerm(StartPos: integer; ExceptionIfNoVariableStart, WithAsOperator: boolean): integer; function FindStartOfTerm(EndPos: integer; InType: boolean): integer; function NodeTermInType(Node: TCodeTreeNode): boolean; function FindExpressionTypeOfTerm(StartPos, EndPos: integer; Params: TFindDeclarationParams; WithAsOperator: boolean): TExpressionType; function FindEndOfExpression(StartPos: integer): integer; function ConvertNodeToExpressionType(Node: TCodeTreeNode; Params: TFindDeclarationParams): TExpressionType; function ReadOperandTypeAtCursor( Params: TFindDeclarationParams; MaxEndPos: integer = -1): TExpressionType; function FindExpressionTypeOfPredefinedIdentifier(StartPos: integer; Params: TFindDeclarationParams): TExpressionType; function CalculateBinaryOperator(LeftOperand, RightOperand: TExpressionType; BinaryOperator: TAtomPosition; Params: TFindDeclarationParams): TExpressionType; function GetParameterNode(Node: TCodeTreeNode): TCodeTreeNode; function GetExpressionTypeOfTypeIdentifier( Params: TFindDeclarationParams): TExpressionType; function FindTermTypeAsString(TermPos: TAtomPosition; CursorNode: TCodeTreeNode; Params: TFindDeclarationParams; out ExprType: TExpressionType): string; function FindForInTypeAsString(TermPos: TAtomPosition; CursorNode: TCodeTreeNode; Params: TFindDeclarationParams; out ExprType: TExpressionType): string; function FindEnumeratorOfClass(ClassNode: TCodeTreeNode; ExceptionOnNotFound: boolean; out ExprType: TExpressionType): boolean; function FindOperatorEnumerator(Node: TCodeTreeNode; ExprType: TExpressionType; Need: TFindOperatorEnumerator; out ResultExprType: TExpressionType): boolean; function FindEnumerationTypeOfSetType(SetTypeNode: TCodeTreeNode; out Context: TFindContext): boolean; function FindElementTypeOfArrayType(ArrayNode: TCodeTreeNode; out ExprType: TExpressionType): boolean; function CheckOperatorEnumerator(Params: TFindDeclarationParams; const FoundContext: TFindContext): TIdentifierFoundResult; function CheckModifierEnumeratorCurrent(Params: TFindDeclarationParams; const FoundContext: TFindContext): TIdentifierFoundResult; function IsTermEdgedBracket(TermPos: TAtomPosition; out EdgedBracketsStartPos: integer): boolean; function IsTermNamedPointer(TermPos: TAtomPosition; out ExprType: TExpressionType): boolean; function FindSetOfEnumerationType(EnumNode: TCodeTreeNode): TCodeTreeNode; function FindPointerOfIdentifier(TypeNode: TCodeTreeNode): TCodeTreeNode; function FindExprTypeAsString(const ExprType: TExpressionType; TermCleanPos: integer; Params: TFindDeclarationParams): string; protected function CheckSrcIdentifier(Params: TFindDeclarationParams; const FoundContext: TFindContext): TIdentifierFoundResult; function FindDeclarationOfIdentAtParam( Params: TFindDeclarationParams): boolean; function IdentifierIsDefined(IdentAtom: TAtomPosition; ContextNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean; function FindContextNodeAtCursor( Params: TFindDeclarationParams): TFindContext; function FindClassOfMethod(ProcNode: TCodeTreeNode; Params: TFindDeclarationParams; FindClassContext: boolean): boolean; function FindForwardIdentifier(Params: TFindDeclarationParams; var IsForward: boolean): boolean; function FindNonForwardClass(Params: TFindDeclarationParams): boolean; function FindExpressionResultType(Params: TFindDeclarationParams; StartPos, EndPos: integer): TExpressionType; function FindCodeToolForUsedUnit(UnitNameAtom, UnitInFileAtom: TAtomPosition; ExceptionOnNotFound: boolean): TFindDeclarationTool; function FindCodeToolForUsedUnit(const AnUnitName, AnUnitInFilename: string; ExceptionOnNotFound: boolean): TFindDeclarationTool; function FindUnitSourceWithUnitIdentifier(UsesNode: TCodeTreeNode; const AnUnitIdentifier: string; ExceptionOnNotFound: boolean ): TCodeBuffer; function FindCodeToolForUnitIdentifier(UsesNode: TCodeTreeNode; const AnUnitIdentifier: string; ExceptionOnNotFound: boolean ): TFindDeclarationTool; function FindIdentifierInInterface(AskingTool: TFindDeclarationTool; Params: TFindDeclarationParams): boolean; function CompareNodeIdentifier(Node: TCodeTreeNode; Params: TFindDeclarationParams): boolean; function GetInterfaceNode: TCodeTreeNode; function CompatibilityList1IsBetter(List1, List2: TTypeCompatibilityList; ListCount: integer): boolean; function IsParamExprListCompatibleToNodeList( FirstTargetParameterNode: TCodeTreeNode; SourceExprParamList: TExprTypeList; IgnoreMissingParameters: boolean; Params: TFindDeclarationParams; CompatibilityList: TTypeCompatibilityList): TTypeCompatibility; function IsParamNodeListCompatibleToParamNodeList(FirstTargetParameterNode, FirstSourceParameterNode: TCodeTreeNode; Params: TFindDeclarationParams; CompatibilityList: TTypeCompatibilityList): TTypeCompatibility; function CreateParamExprListFromStatement(StartPos: integer; Params: TFindDeclarationParams): TExprTypeList; function CreateParamExprListFromProcNode(ProcNode: TCodeTreeNode; Params: TFindDeclarationParams): TExprTypeList; function ContextIsDescendOf( const DescendContext, AncestorContext: TFindContext; Params: TFindDeclarationParams): boolean; function IsCompatible(TargetNode: TCodeTreeNode; const ExpressionType: TExpressionType; Params: TFindDeclarationParams): TTypeCompatibility; function IsCompatible(TargetType, ExpressionType: TExpressionType; Params: TFindDeclarationParams): TTypeCompatibility; function IsBaseCompatible(const TargetType, ExpressionType: TExpressionType; Params: TFindDeclarationParams): TTypeCompatibility; function CheckParameterSyntax(CursorNode: TCodeTreeNode; CleanCursorPos: integer; out ParameterAtom, ProcNameAtom: TAtomPosition; out ParameterIndex: integer): boolean; protected function OpenCodeToolForUnit(UnitNameAtom, UnitInFileAtom: TAtomPosition; ExceptionOnNotFound: boolean): TFindDeclarationTool; function CheckDirectoryCache: boolean; public destructor Destroy; override; procedure ConsistencyCheck; override; procedure CalcMemSize(Stats: TCTMemStats); override; procedure BeginParsing(DeleteNodes, OnlyInterfaceNeeded: boolean); override; procedure ValidateToolDependencies; override; function BuildInterfaceIdentifierCache(ExceptionOnNotUnit: boolean): boolean; function FindDeclaration(const CursorPos: TCodeXYPosition; out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean; function FindMainDeclaration(const CursorPos: TCodeXYPosition; out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean; function FindDeclarationOfIdentifier(const CursorPos: TCodeXYPosition; Identifier: PChar; out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean; function FindDeclaration(const CursorPos: TCodeXYPosition; SearchSmartFlags: TFindSmartFlags; var NewTool: TFindDeclarationTool; var NewNode: TCodeTreeNode; out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean; function FindDeclarationInInterface(const Identifier: string; out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean; function FindDeclarationWithMainUsesSection(const Identifier: string; out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean; function FindDeclarationOfPropertyPath(const PropertyPath: string; out NewContext: TFindContext; IgnoreTypeLess: boolean = false): boolean; function FindDeclarationOfPropertyPath(const PropertyPath: string; out NewPos: TCodeXYPosition; out NewTopLine: integer; IgnoreTypeLess: boolean = false): boolean; function FindDeclarationNodeInInterface(const Identifier: string; BuildTheTree: Boolean): TCodeTreeNode;// search for type, const, var function FindInitializationSection: TCodeTreeNode; function FindMainUsesSection(UseContainsSection: boolean = false): TCodeTreeNode; function FindImplementationUsesSection: TCodeTreeNode; function FindNameInUsesSection(UsesNode: TCodeTreeNode; const AUnitName: string): TCodeTreeNode; function FindUnitInUsesSection(UsesNode: TCodeTreeNode; const AnUnitName: string; out NamePos, InPos: TAtomPosition): boolean; function FindUnitInAllUsesSections(const AnUnitName: string; out NamePos, InPos: TAtomPosition): boolean; function GetUnitForUsesSection(Tool: TFindDeclarationTool): string; function FindUnitSource(const AnUnitName, AnUnitInFilename: string; ExceptionOnNotFound: boolean): TCodeBuffer; function FindUnitCaseInsensitive(var AnUnitName, AnUnitInFilename: string): string; procedure GatherUnitAndSrcPath(var UnitPath, CompleteSrcPath: string); function SearchUnitInUnitLinks(const TheUnitName: string): string; function FindSmartHint(const CursorPos: TCodeXYPosition): string; function BaseTypeOfNodeHasSubIdents(ANode: TCodeTreeNode): boolean; function FindBaseTypeOfNode(Params: TFindDeclarationParams; Node: TCodeTreeNode): TFindContext; function FindDeclarationAndOverload(const CursorPos: TCodeXYPosition; out ListOfPCodeXYPosition: TFPList; Flags: TFindDeclarationListFlags): boolean; function FindClassAndAncestors(ClassNode: TCodeTreeNode; out ListOfPFindContext: TFPList): boolean; // without interfaces function FindContextClassAndAncestors(const CursorPos: TCodeXYPosition; var ListOfPFindContext: TFPList): boolean; // without interfaces function FindAncestorOfClass(ClassNode: TCodeTreeNode; Params: TFindDeclarationParams; FindClassContext: boolean): boolean; // returns false for TObject, IInterface, IUnknown function FindAncestorOfClassInheritance(IdentifierNode: TCodeTreeNode; Params: TFindDeclarationParams; FindClassContext: boolean): boolean; function FindAncestorsOfClass(ClassNode: TCodeTreeNode; var ListOfPFindContext: TFPList; Params: TFindDeclarationParams; FindClassContext: boolean; ExceptionOnNotFound: boolean = true): boolean; // with interfaces function FindReferences(const CursorPos: TCodeXYPosition; SkipComments: boolean; out ListOfPCodeXYPosition: TFPList): boolean; function FindUnitReferences(UnitCode: TCodeBuffer; SkipComments: boolean; out ListOfPCodeXYPosition: TFPList): boolean; function CleanPosIsDeclarationIdentifier(CleanPos: integer; Node: TCodeTreeNode): boolean; function FindIdentifierInContext(Params: TFindDeclarationParams): boolean; function FindNthParameterNode(Node: TCodeTreeNode; ParameterIndex: integer): TCodeTreeNode; function GetFirstParameterNode(Node: TCodeTreeNode): TCodeTreeNode; function IsParamNodeListCompatibleToExprList( TargetExprParamList: TExprTypeList; FirstSourceParameterNode: TCodeTreeNode; Params: TFindDeclarationParams; CompatibilityList: TTypeCompatibilityList): TTypeCompatibility; function JumpToNode(ANode: TCodeTreeNode; out NewPos: TCodeXYPosition; out NewTopLine: integer; IgnoreJumpCentered: boolean): boolean; function JumpToCleanPos(NewCleanPos, NewTopLineCleanPos, NewBottomLineCleanPos: integer; out NewPos: TCodeXYPosition; out NewTopLine: integer; IgnoreJumpCentered: boolean): boolean; function NodeIsForwardDeclaration(Node: TCodeTreeNode): boolean; property InterfaceIdentifierCache: TInterfaceIdentifierCache read FInterfaceIdentifierCache; property OnGetUnitSourceSearchPath: TOnGetSearchPath read FOnGetUnitSourceSearchPath write FOnGetUnitSourceSearchPath; property OnFindUsedUnit: TOnFindUsedUnit read FOnFindUsedUnit write FOnFindUsedUnit; property OnGetCodeToolForBuffer: TOnGetCodeToolForBuffer read FOnGetCodeToolForBuffer write FOnGetCodeToolForBuffer; property OnGetDirectoryCache: TOnGetDirectoryCache read FOnGetDirectoryCache write FOnGetDirectoryCache; property OnGetSrcPathForCompiledUnit: TOnGetSrcPathForCompiledUnit read FOnGetSrcPathForCompiledUnit write fOnGetSrcPathForCompiledUnit; property OnGetMethodName: TOnGetMethodname read FOnGetMethodName write FOnGetMethodName; property AdjustTopLineDueToComment: boolean read FAdjustTopLineDueToComment write FAdjustTopLineDueToComment; property DirectoryCache: TCTDirectoryCache read FDirectoryCache; end; function ExprTypeToString(const ExprType: TExpressionType): string; function CreateExpressionType(const Desc, SubDesc: TExpressionTypeDesc; const Context: TFindContext): TExpressionType; function FindContextToString(const FindContext: TFindContext): string; function CreateFindContext(NewTool: TFindDeclarationTool; NewNode: TCodeTreeNode): TFindContext; function CreateFindContext(Params: TFindDeclarationParams): TFindContext; function CreateFindContext(BaseTypeCache: TBaseTypeCache): TFindContext; function FindContextAreEqual(const Context1, Context2: TFindContext): boolean; function CompareFindContexts(const Context1, Context2: PFindContext): integer; procedure AddFindContext(var ListOfPFindContext: TFPList; const NewContext: TFindContext); function IndexOfFindContext(var ListOfPFindContext: TFPList; const AContext: PFindContext): integer; procedure FreeListOfPFindContext(var ListOfPFindContext: TFPList); function ListOfPFindContextToStr(const ListOfPFindContext: TFPList): string; function DbgsFC(const Context: TFindContext): string; function PredefinedIdentToExprTypeDesc(Identifier: PChar): TExpressionTypeDesc; function FindDeclarationFlagsAsString( const Flags: TFindDeclarationFlags): string; function FoundDeclarationFlagsAsString( const Flags: TFoundDeclarationFlags): string; implementation function FindDeclarationFlagsAsString( const Flags: TFindDeclarationFlags): string; var Flag: TFindDeclarationFlag; begin Result:=''; for Flag:=Low(TFindDeclarationFlag) to High(TFindDeclarationFlag) do begin if Flag in Flags then begin if Result<>'' then Result:=Result+', '; Result:=Result+FindDeclarationFlagNames[Flag]; end; end; end; function FoundDeclarationFlagsAsString( const Flags: TFoundDeclarationFlags): string; var Flag: TFoundDeclarationFlag; begin Result:=''; for Flag:=Low(TFoundDeclarationFlag) to High(TFoundDeclarationFlag) do begin if Flag in Flags then begin if Result<>'' then Result:=Result+', '; Result:=Result+FoundDeclarationFlagNames[Flag]; end; end; end; function ListOfPFindContextToStr(const ListOfPFindContext: TFPList): string; var Context: TFindContext; i: Integer; begin if ListOfPFindContext=nil then Result:='nil' else begin Result:=''; for i:=0 to ListOfPFindContext.Count-1 do begin Context:=PFindContext(ListOfPFindContext[i])^; Result:=Result+' '+DbgsFC(Context)+LineEnding; end; end; end; function DbgsFC(const Context: TFindContext): string; var CursorPos: TCodeXYPosition; begin if Context.Tool=nil then Result:='nil' else begin Result:=Context.Tool.MainFilename; if Context.Node=nil then Result:=Result+'()' else begin Context.Tool.CleanPosToCaret(Context.Node.StartPos,CursorPos); Result:=Result+'(y='+dbgs(CursorPos.Y)+',x='+dbgs(CursorPos.X)+')'; end; end; end; function PredefinedIdentToExprTypeDesc(Identifier: PChar): TExpressionTypeDesc; begin // predefined identifiers if CompareIdentifiers(Identifier,'NIL')=0 then Result:=xtNil else if CompareIdentifiers(Identifier,'POINTER')=0 then Result:=xtPointer else if (CompareIdentifiers(Identifier,'TRUE')=0) or (CompareIdentifiers(Identifier,'FALSE')=0) then Result:=xtConstBoolean else if CompareIdentifiers(Identifier,'STRING')=0 then Result:=xtString else if CompareIdentifiers(Identifier,'SHORTSTRING')=0 then Result:=xtShortString else if CompareIdentifiers(Identifier,'ANSISTRING')=0 then Result:=xtAnsiString else if CompareIdentifiers(Identifier,'WIDESTRING')=0 then Result:=xtWideString else if CompareIdentifiers(Identifier,'UNICODESTRING')=0 then Result:=xtUnicodeString else if CompareIdentifiers(Identifier,'INT64')=0 then Result:=xtInt64 else if CompareIdentifiers(Identifier,'CARDINAL')=0 then Result:=xtCardinal else if CompareIdentifiers(Identifier,'QWORD')=0 then Result:=xtQWord else if CompareIdentifiers(Identifier,'BOOLEAN')=0 then Result:=xtBoolean else if CompareIdentifiers(Identifier,'BYTEBOOL')=0 then Result:=xtByteBool else if CompareIdentifiers(Identifier,'WORDBOOL')=0 then Result:=xtWordBool else if CompareIdentifiers(Identifier,'LONGBOOL')=0 then Result:=xtLongBool else if CompareIdentifiers(Identifier,'QWORDBOOL')=0 then Result:=xtQWordBool else if CompareIdentifiers(Identifier,'CHAR')=0 then Result:=xtChar else if CompareIdentifiers(Identifier,'WIDECHAR')=0 then Result:=xtWideChar else if CompareIdentifiers(Identifier,'REAL')=0 then Result:=xtReal else if CompareIdentifiers(Identifier,'SINGLE')=0 then Result:=xtSingle else if CompareIdentifiers(Identifier,'DOUBLE')=0 then Result:=xtDouble else if CompareIdentifiers(Identifier,'EXTENDED')=0 then Result:=xtExtended else if CompareIdentifiers(Identifier,'COMP')=0 then Result:=xtComp else if CompareIdentifiers(Identifier,'FILE')=0 then Result:=xtFile else if CompareIdentifiers(Identifier,'TEXT')=0 then Result:=xtText else if CompareIdentifiers(Identifier,'SIZEOF')=0 then Result:=xtConstOrdInteger else if CompareIdentifiers(Identifier,'ORD')=0 then Result:=xtConstOrdInteger else if CompareIdentifiers(Identifier,'VARIANT')=0 then Result:=xtVariant else if IsWordBuiltInFunc.DoItCaseInsensitive(Identifier) then Result:=xtCompilerFunc // the delphi compiler special types else if CompareIdentifiers(Identifier,'CURRENCY')=0 then Result:=xtCurrency else if CompareIdentifiers(Identifier,'LONGINT')=0 then Result:=xtLongInt else if CompareIdentifiers(Identifier,'LONGWORD')=0 then Result:=xtLongWord else if CompareIdentifiers(Identifier,'WORD')=0 then Result:=xtWord else if CompareIdentifiers(Identifier,'LONGWORD')=0 then Result:=xtCardinal else if CompareIdentifiers(Identifier,'SMALLINT')=0 then Result:=xtSmallInt else if CompareIdentifiers(Identifier,'SHORTINT')=0 then Result:=xtShortInt else if CompareIdentifiers(Identifier,'BYTE')=0 then Result:=xtByte else if CompareIdentifiers(Identifier,'PCHAR')=0 then Result:=xtPChar else Result:=xtNone; end; function ExprTypeToString(const ExprType: TExpressionType): string; begin Result:='Desc='+ExpressionTypeDescNames[ExprType.Desc] +' SubDesc='+ExpressionTypeDescNames[ExprType.SubDesc] +' '+FindContextToString(ExprType.Context); end; function CreateExpressionType(const Desc, SubDesc: TExpressionTypeDesc; const Context: TFindContext): TExpressionType; begin Result.Desc:=Desc; Result.SubDesc:=SubDesc; Result.Context:=Context; end; { TFindContext } function FindContextToString(const FindContext: TFindContext): string; var IdentNode: TCodeTreeNode; Caret: TCodeXYPosition; begin Result:=''; if FindContext.Node<>nil then begin Result:=Result+'Node='+FindContext.Node.DescAsString; IdentNode:=FindContext.Node; while (IdentNode<>nil) do begin if IdentNode.Desc in AllSimpleIdentifierDefinitions then begin Result:=Result+' Ident="'+ FindContext.Tool.ExtractIdentifier(IdentNode.StartPos)+'"'; break; end else if IdentNode.Desc=ctnGenericType then begin if IdentNode.FirstChild<>nil then Result:=Result+' Generic="'+ FindContext.Tool.ExtractIdentifier(IdentNode.FirstChild.StartPos)+'"' else Result:=Result+' Generic=?'; end else if IdentNode.Desc=ctnProperty then begin Result:=Result+' PropName="'+ FindContext.Tool.ExtractPropName(IdentNode,false)+'"'; break; end; IdentNode:=IdentNode.Parent; end; if FindContext.Tool<>nil then begin if FindContext.Tool.CleanPosToCaret(FindContext.Node.StartPos,Caret) then begin Result:=Result+' File='+Caret.Code.Filename +'('+IntToStr(Caret.Y)+','+IntToStr(Caret.X)+')'; end else begin Result:=Result+' File="'+FindContext.Tool.MainFilename+'"'; end; end; end; end; function CreateFindContext(NewTool: TFindDeclarationTool; NewNode: TCodeTreeNode): TFindContext; begin Result.Node:=NewNode; Result.Tool:=NewTool; end; function CreateFindContext(Params: TFindDeclarationParams): TFindContext; begin Result.Node:=Params.NewNode; Result.Tool:=TFindDeclarationTool(Params.NewCodeTool); end; function CreateFindContext(BaseTypeCache: TBaseTypeCache): TFindContext; begin Result.Node:=BaseTypeCache.NewNode; Result.Tool:=TFindDeclarationTool(BaseTypeCache.NewTool); end; function FindContextAreEqual(const Context1, Context2: TFindContext): boolean; begin Result:=(Context1.Tool=Context2.Tool) and (Context1.Node=Context2.Node); end; function CompareFindContexts(const Context1, Context2: PFindContext): integer; begin if Pointer(Context1^.Tool)>Pointer(Context2^.Tool) then Result:=1 else if Pointer(Context1^.Tool)Pointer(Context2^.Node) then Result:=1 else if Pointer(Context1^.Node)=0) and (CompareFindContexts(AContext, PFindContext(ListOfPFindContext[Result]))<>0) do dec(Result); end; end; procedure FreeListOfPFindContext(var ListOfPFindContext: TFPList); var CurContext: PFindContext; i: Integer; begin if ListOfPFindContext=nil then exit; for i:=0 to ListOfPFindContext.Count-1 do begin CurContext:=PFindContext(ListOfPFindContext[i]); Dispose(CurContext); end; ListOfPFindContext.Free; ListOfPFindContext:=nil; end; { TFindDeclarationTool } function TFindDeclarationTool.FindDeclaration(const CursorPos: TCodeXYPosition; out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean; var NewTool: TFindDeclarationTool; NewNode: TCodeTreeNode; begin Result:=FindDeclaration(CursorPos,DefaultFindSmartFlags,NewTool,NewNode, NewPos,NewTopLine); end; function TFindDeclarationTool.FindMainDeclaration( const CursorPos: TCodeXYPosition; out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean; var NewTool: TFindDeclarationTool; NewNode: TCodeTreeNode; begin Result:=FindDeclaration(CursorPos,[fsfFindMainDeclaration],NewTool,NewNode, NewPos,NewTopLine); end; function TFindDeclarationTool.FindDeclarationOfIdentifier( const CursorPos: TCodeXYPosition; Identifier: PChar; out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean; var CleanCursorPos: integer; CursorNode: TCodeTreeNode; Params: TFindDeclarationParams; begin Result:=false; ActivateGlobalWriteLock; Params:=nil; try // build code tree {$IFDEF CTDEBUG} DebugLn('TFindDeclarationTool.FindDeclarationOfIdentifier A CursorPos=X',dbgs(CursorPos.X),',Y',dbgs(CursorPos.Y)); {$ENDIF} if DirtySrc<>nil then DirtySrc.Clear; BuildTreeAndGetCleanPos(trTillCursor,CursorPos,CleanCursorPos, [{$IFNDEF DisableIgnoreErrorAfter}btSetIgnoreErrorPos{$ENDIF}]); {$IFDEF CTDEBUG} DebugLn('TFindDeclarationTool.FindDeclarationOfIdentifier B CleanCursorPos=',dbgs(CleanCursorPos)); {$ENDIF} // find CodeTreeNode at cursor CursorNode:=BuildSubTreeAndFindDeepestNodeAtPos(CleanCursorPos,true); // search Params:=TFindDeclarationParams.Create; Params.ContextNode:=CursorNode; Params.SetIdentifier(Self,Identifier,nil); Params.Flags:=[fdfSearchInParentNodes,fdfExceptionOnNotFound, fdfExceptionOnPredefinedIdent, fdfTopLvlResolving,fdfSearchInAncestors, fdfIgnoreCurContextNode]; FindIdentifierInContext(Params); // convert result to nice source position Params.PrettifyResult; Params.ConvertResultCleanPosToCaretPos; NewPos:=Params.NewPos; NewTopLine:=Params.NewTopLine; Result:=true; finally Params.Free; DeactivateGlobalWriteLock; end; end; function TFindDeclarationTool.FindDeclaration(const CursorPos: TCodeXYPosition; SearchSmartFlags: TFindSmartFlags; var NewTool: TFindDeclarationTool; var NewNode: TCodeTreeNode; out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean; var CleanCursorPos: integer; CursorNode, ClassNode: TCodeTreeNode; Params: TFindDeclarationParams; DirectSearch, SkipChecks, SearchForward: boolean; procedure CheckIfCursorOnAForwardDefinedClass; var TypeNode: TCodeTreeNode; begin if SkipChecks then exit; if CursorNode.Desc in [ctnTypeDefinition,ctnGenericType] then begin TypeNode:=FindTypeNodeOfDefinition(CursorNode); if (TypeNode<>nil) and (TypeNode.Desc in AllClasses) and ((TypeNode.SubDesc and ctnsForwardDeclaration)>0) then begin DirectSearch:=true; SearchForward:=true; SkipChecks:=true; end; end; end; procedure CheckIfCursorInTypeNode; begin if (CursorNode.Desc in AllIdentifierDefinitions) and (fsfSkipClassForward in SearchSmartFlags) then Exclude(SearchSmartFlags,fsfSkipClassForward); end; procedure CheckIfCursorInClassNode; begin if SkipChecks then exit; ClassNode:=CursorNode; while (ClassNode<>nil) and (not (ClassNode.Desc in AllClasses)) do ClassNode:=ClassNode.Parent; if ClassNode<>nil then begin // cursor is in class/object/class interface definition if (ClassNode.SubDesc and ctnsForwardDeclaration)=0 then begin // parse class and build CodeTreeNodes for all properties/methods BuildSubTreeForClass(ClassNode); CursorNode:=FindDeepestNodeAtPos(ClassNode,CleanCursorPos,true); if CursorNode.GetNodeOfType(ctnClassInheritance)<>nil then begin // identifier is an ancestor/interface identifier CursorNode:=ClassNode.Parent; DirectSearch:=true; SkipChecks:=true; end; end; end; end; procedure CheckIfCursorInBeginNode; begin if SkipChecks then exit; if CursorNode.Desc=ctnBeginBlock then begin BuildSubTreeForBeginBlock(CursorNode); CursorNode:=FindDeepestNodeAtPos(CursorNode,CleanCursorPos,true); end; end; procedure CheckIfCursorInProcNode; var IsMethod: boolean; begin if SkipChecks then exit; if CursorNode.Desc=ctnProcedureHead then CursorNode:=CursorNode.Parent; if CursorNode.Desc=ctnProcedure then begin BuildSubTreeForProcHead(CursorNode); CursorNode:=FindDeepestNodeAtPos(CursorNode,CleanCursorPos,true); // check if cursor on proc name if (CursorNode.Desc=ctnProcedureHead) and (CleanCursorPos>=CursorNode.StartPos) then begin MoveCursorToNodeStart(CursorNode); ReadNextAtom; IsMethod:=false; if AtomIsIdentifier(false) then begin ReadNextAtom; if AtomIsChar('.') then begin ReadNextAtom; ReadNextAtom; IsMethod:=true; end; end; if (CurPos.StartPos>CleanCursorPos) and (not IsMethod) then begin // cursor on proc name // -> ignore proc name and search overloaded identifier DirectSearch:=true; SkipChecks:=true; end; end; if CursorNode.Desc=ctnProcedureHead then CursorNode:=CursorNode.Parent; end; end; procedure CheckIfCursorInPropertyNode; begin if SkipChecks then exit; if (CursorNode.Desc=ctnProperty) or (CursorNode.Desc=ctnGlobalProperty) then begin MoveCursorToNodeStart(CursorNode); if (CursorNode.Desc=ctnProperty) then begin ReadNextAtom; // read 'property' if UpAtomIs('CLASS') then ReadNextAtom; end; ReadNextAtom; // read property name if CleanCursorPosCursorPos.Code.LineCount) or (CursorPos.X<1) then exit; CursorPos.Code.GetLineRange(CursorPos.Y-1,LineRange); if LineRange.EndPos-LineRange.StartPos+1nil then DirtySrc.Clear; BuildTreeAndGetCleanPos(trTillCursor,CursorPos,CleanCursorPos, [{$IFNDEF DisableIgnoreErrorAfter}btSetIgnoreErrorPos,{$ENDIF} btLoadDirtySource,btCursorPosOutAllowed]); {$IFDEF CTDEBUG} DebugLn('TFindDeclarationTool.FindDeclaration C CleanCursorPos=',dbgs(CleanCursorPos)); {$ENDIF} // find CodeTreeNode at cursor if (Tree.Root<>nil) and (Tree.Root.StartPos<=CleanCursorPos) then begin CursorNode:=BuildSubTreeAndFindDeepestNodeAtPos(CleanCursorPos,true); if (fsfFindMainDeclaration in SearchSmartFlags) and CleanPosIsDeclarationIdentifier(CleanCursorPos,CursorNode) then begin //DebugLn(['TFindDeclarationTool.FindDeclaration CleanPosIsDeclarationIdentifier']); NewTool:=Self; NewNode:=CursorNode; CleanCursorPos:=GetIdentStartPosition(Src,CleanCursorPos); Result:=JumpToCleanPos(CleanCursorPos,CleanCursorPos,CleanCursorPos, NewPos,NewTopLine,false); exit; end; CleanPosInFront:=CursorNode.StartPos; end else begin CleanPosInFront:=1; CursorNode:=nil; end; if (not IsDirtySrcValid) and IsIncludeDirectiveAtPos(CleanCursorPos,CleanPosInFront,NewPos.Code) then begin // include directive //DebugLn(['TFindDeclarationTool.FindDeclaration IsIncludeDirectiveAtPos']); NewPos.X:=1; NewPos.Y:=1; NewTopLine:=1; NewNode:=nil; NewTool:=Self; Result:=(fsfIncludeDirective in SearchSmartFlags); exit; end; if CursorNode=nil then begin // raise exception CursorNode:=FindDeepestNodeAtPos(CleanCursorPos,true); end; {$IFDEF CTDEBUG} DebugLn('TFindDeclarationTool.FindDeclaration D CursorNode=',NodeDescriptionAsString(CursorNode.Desc),' HasChilds=',dbgs(CursorNode.FirstChild<>nil)); {$ENDIF} if (not IsDirtySrcValid) and (CursorNode.Desc in [ctnUsesSection,ctnUseUnit]) then begin // in uses section //DebugLn(['TFindDeclarationTool.FindDeclaration IsUsesSection']); Result:=FindDeclarationInUsesSection(CursorNode,CleanCursorPos, NewPos,NewTopLine); NewNode:=nil; NewTool:=nil; if Result and (fsfSearchSourceName in SearchSmartFlags) then Result:=FindSourceName(NewPos.Code); exit; end; DirectSearch:=false; SearchForward:=false; CheckIfCursorOnAForwardDefinedClass; CheckIfCursorInClassNode; CheckIfCursorInTypeNode; CheckIfCursorInBeginNode; CheckIfCursorInProcNode; CheckIfCursorInPropertyNode; // set cursor on identifier MoveCursorToCleanPos(CleanCursorPos); if IsDirtySrcValid then begin DirtySrc.SetCursorToIdentStartEndAtPosition; CursorAtIdentifier:=DirtySrc.CurPos.StartPosnil then Result:=JumpToNode(Node,NewPos,NewTopLine,false); end; function TFindDeclarationTool.FindDeclarationWithMainUsesSection( const Identifier: string; out NewPos: TCodeXYPosition; out NewTopLine: integer ): boolean; var UsesNode: TCodeTreeNode; Params: TFindDeclarationParams; begin Result:=false; if Identifier='' then exit; BuildTree(false); UsesNode:=FindMainUsesSection; if UsesNode=nil then exit; Params:=TFindDeclarationParams.Create; ActivateGlobalWriteLock; try Params.Flags:=[fdfExceptionOnNotFound]; Params.SetIdentifier(Self,PChar(Pointer(Identifier)),nil); if FindIdentifierInUsesSection(UsesNode,Params) then begin if Params.NewNode=nil then exit; Result:=Params.NewCodeTool.JumpToNode(Params.NewNode,NewPos, NewTopLine,false); end; finally Params.Free; DeactivateGlobalWriteLock; end; end; function TFindDeclarationTool.FindDeclarationOfPropertyPath( const PropertyPath: string; out NewContext: TFindContext; IgnoreTypeLess: boolean): boolean; // example: PropertyPath='TForm1.Font.Color' var StartPos: Integer; function GetNextIdentifier: string; var EndPos: LongInt; begin EndPos:=StartPos; while (EndPos<=length(PropertyPath)) and (IsIdentChar[PropertyPath[EndPos]]) do inc(EndPos); if (EndPos<=length(PropertyPath)) and (PropertyPath[EndPos]<>'.') then Result:='' else begin Result:=copy(PropertyPath,StartPos,EndPos-StartPos); StartPos:=EndPos+1; end; end; var Params: TFindDeclarationParams; Identifier: String; IsLastProperty: Boolean; Context: TFindContext; IsTypeLess: Boolean; begin Result:=false; NewContext:=CleanFindContext; //DebugLn('TFindDeclarationTool.FindDeclarationOfPropertyPath PropertyPath="',PropertyPath,'"'); if PropertyPath='' then exit; ActivateGlobalWriteLock; Params:=TFindDeclarationParams.Create; try BuildTree(false); //DebugLn(['TFindDeclarationTool.FindDeclarationOfPropertyPath ',Src]); // first search the class/variable in the interface StartPos:=1; Identifier:=GetNextIdentifier; if Identifier='' then exit; Context.Tool:=Self; Context.Node:=FindDeclarationNodeInInterface(Identifier,true); if Context.Node=nil then begin DebugLn(['TFindDeclarationTool.FindDeclarationOfPropertyPath Identifier not found in interface ',Identifier]); exit; end; Context:=FindBaseTypeOfNode(Params,Context.Node); if Context.Node=nil then begin DebugLn(['TFindDeclarationTool.FindDeclarationOfPropertyPath context not found']); exit; end; // then search the properties repeat //DebugLn('TFindDeclarationTool.FindDeclarationOfPropertyPath ',Context.Node.DescAsString); if (not (Context.Node.Desc in (AllClasses+[ctnRecordType]))) then exit; Params.Flags:=[fdfExceptionOnNotFound,fdfSearchInAncestors]; Identifier:=GetNextIdentifier; //DebugLn('TFindDeclarationTool.FindDeclarationOfPropertyPath Identifier="',identifier,'"'); if Identifier='' then exit; Params.SetIdentifier(Self,PChar(Pointer(Identifier)),nil); Params.ContextNode:=Context.Node; IsLastProperty:=StartPos>length(PropertyPath); if IsLastProperty then Params.Flags:=Params.Flags+[fdfFindVariable] else Params.Flags:=Params.Flags-[fdfFindVariable]+[fdfFunctionResult,fdfFindChilds]; if not Context.Tool.FindIdentifierInContext(Params) then exit; Context.Tool:=Params.NewCodeTool; Context.Node:=Params.NewNode; if Context.Node=nil then exit; if IsLastProperty then begin if IgnoreTypeLess then begin repeat IsTypeLess:=false; if (Context.Node.Desc=ctnProperty) and Context.Tool.PropNodeIsTypeLess(Context.Node) then IsTypeLess:=true; if not IsTypeLess then break; //DebugLn(['TFindDeclarationTool.FindDeclarationOfPropertyPath has not type, searching next ...']); Params.SetIdentifier(Self,PChar(Pointer(Identifier)),nil); Params.ContextNode:=Context.Tool.FindClassOrInterfaceNode(Context.Node); if Params.ContextNode=nil then Params.ContextNode:=Context.Node; Params.Flags:=[fdfExceptionOnNotFound,fdfSearchInAncestors, fdfFindVariable,fdfIgnoreCurContextNode]; //DebugLn(['TFindDeclarationTool.FindDeclarationOfPropertyPath ',Context.Tool.MainFilename,' ',Params.ContextNode.DescAsString,' ',Context.Tool.CleanPosToStr(Params.ContextNode.StartPos)]); if not Context.Tool.FindIdentifierInContext(Params) then exit; Context.Tool:=Params.NewCodeTool; Context.Node:=Params.NewNode; if Context.Node=nil then exit; until false; end; //DebugLn(['TFindDeclarationTool.FindDeclarationOfPropertyPath FOUND']); NewContext:=Context; Result:=true; exit; end else begin Context:=Context.Tool.FindBaseTypeOfNode(Params,Context.Node); if Context.Node=nil then exit; end; until false; finally Params.Free; DeactivateGlobalWriteLock; end; end; function TFindDeclarationTool.FindDeclarationOfPropertyPath( const PropertyPath: string; out NewPos: TCodeXYPosition; out NewTopLine: integer; IgnoreTypeLess: boolean): boolean; var Context: TFindContext; begin Result:=FindDeclarationOfPropertyPath(PropertyPath,Context,IgnoreTypeLess); if not Result then exit; Result:=Context.Tool.JumpToNode(Context.Node,NewPos,NewTopLine,false); end; function TFindDeclarationTool.FindDeclarationNodeInInterface( const Identifier: string; BuildTheTree: Boolean): TCodeTreeNode; var StartNode: TCodeTreeNode; SectionNode: TCodeTreeNode; Node: TCodeTreeNode; BestNodeIsForwardDeclaration: Boolean; CurNodeIsForwardDeclaration: Boolean; BestNode: TCodeTreeNode; NameNode: TCodeTreeNode; begin Result:=nil; if Identifier='' then exit; if BuildTheTree then BuildTree(true); if Tree.Root=nil then exit; if Tree.Root.Desc=ctnUnit then StartNode:=FindInterfaceNode else StartNode:=Tree.Root; if StartNode=nil then exit; SectionNode:=StartNode.FirstChild; if SectionNode=nil then exit; BestNode:=nil; BestNodeIsForwardDeclaration:=false; while SectionNode<>nil do begin if SectionNode.Desc in AllDefinitionSections then begin Node:=SectionNode.FirstChild; while Node<>nil do begin if Node.Desc in AllIdentifierDefinitions then begin NameNode:=Node; if Node.Desc=ctnGenericType then NameNode:=NameNode.FirstChild; if (NameNode<>nil) and CompareSrcIdentifiers(NameNode.StartPos,PChar(Pointer(Identifier))) then begin CurNodeIsForwardDeclaration:=NodeIsForwardDeclaration(Node); if (BestNode=nil) or BestNodeIsForwardDeclaration then begin BestNode:=Node; BestNodeIsForwardDeclaration:=CurNodeIsForwardDeclaration; end; end; end; Node:=Node.NextBrother; end; end; SectionNode:=SectionNode.NextBrother; end; Result:=BestNode; end; function TFindDeclarationTool.FindMainUsesSection(UseContainsSection: boolean ): TCodeTreeNode; begin Result:=Tree.Root; if Result=nil then exit; if UseContainsSection then begin if Result.Desc<>ctnPackage then exit(nil); Result:=Result.FirstChild; while (Result<>nil) and (Result.Desc<>ctnContainsSection) do Result:=Result.NextBrother; end else begin if Result.Desc=ctnUnit then begin Result:=Result.NextBrother; if Result=nil then exit; end; Result:=Result.FirstChild; if (Result=nil) then exit; if (Result.Desc<>ctnUsesSection) then Result:=nil; end; end; function TFindDeclarationTool.FindImplementationUsesSection: TCodeTreeNode; begin Result:=Tree.Root; if Result=nil then exit; while (Result<>nil) and (Result.Desc<>ctnImplementation) do Result:=Result.NextBrother; if Result=nil then exit; Result:=Result.FirstChild; if (Result=nil) then exit; if (Result.Desc<>ctnUsesSection) then Result:=nil; end; function TFindDeclarationTool.FindNameInUsesSection(UsesNode: TCodeTreeNode; const AUnitName: string): TCodeTreeNode; begin Result:=UsesNode.FirstChild; while (Result<>nil) and (not CompareSrcIdentifiers(Result.StartPos,PChar(AUnitName))) do Result:=Result.NextBrother; end; function TFindDeclarationTool.FindUnitInUsesSection(UsesNode: TCodeTreeNode; const AnUnitName: string; out NamePos, InPos: TAtomPosition): boolean; begin Result:=false; NamePos:=CleanAtomPosition; InPos:=CleanAtomPosition; if (UsesNode=nil) or (AnUnitName='') or (length(AnUnitName)>255) or (UsesNode.Desc<>ctnUsesSection) then begin DebugLn(['TFindDeclarationTool.FindUnitInUsesSection invalid AnUnitName']); exit; end; MoveCursorToNodeStart(UsesNode); ReadNextAtom; // read 'uses' repeat ReadNextAtom; // read name if AtomIsChar(';') then break; if (CurPos.StartPos>SrcLen) then break; if CompareSrcIdentifiers(CurPos.StartPos,@AnUnitName[1]) then begin NamePos:=CurPos; InPos.StartPos:=-1; ReadNextAtom; if UpAtomIs('IN') then begin ReadNextAtom; InPos:=CurPos; end; Result:=true; exit; end; ReadNextAtom; if UpAtomIs('IN') then begin ReadNextAtom; ReadNextAtom; end; if AtomIsChar(';') then break; if not AtomIsChar(',') then break; until (CurPos.StartPos>SrcLen); end; function TFindDeclarationTool.FindUnitInAllUsesSections( const AnUnitName: string; out NamePos, InPos: TAtomPosition): boolean; var SectionNode, UsesNode: TCodeTreeNode; begin Result:=false; NamePos.StartPos:=-1; InPos.StartPos:=-1; if (AnUnitName='') or (length(AnUnitName)>255) then begin DebugLn(['TFindDeclarationTool.FindUnitInAllUsesSections invalid AnUnitName']); exit; end; BuildTree(false); SectionNode:=Tree.Root; while (SectionNode<>nil) and (SectionNode.Desc in [ctnProgram, ctnUnit, ctnPackage,ctnLibrary,ctnInterface,ctnImplementation]) do begin UsesNode:=SectionNode.FirstChild; if (UsesNode<>nil) and (UsesNode.Desc=ctnUsesSection) and FindUnitInUsesSection(UsesNode,AnUnitName,NamePos,InPos) then begin Result:=true; exit; end; SectionNode:=SectionNode.NextBrother; end; end; function TFindDeclarationTool.GetUnitForUsesSection(Tool: TFindDeclarationTool ): string; var UsesNode: TCodeTreeNode; Alternative: String; begin Result:=''; if (Tool=nil) or (Tool.MainFilename='') or (Tool=Self) then exit; Result:=ExtractFileNameOnly(Tool.MainFilename); if Result='' then exit; // check if system unit if (CompareIdentifiers(PChar(Result),'system')=0) or ((Scanner.CompilerMode in [cmDELPHI,cmOBJFPC]) and (Scanner.PascalCompiler=pcFPC) and (CompareIdentifiers(PChar(Result),'ObjPas')=0)) or ((Scanner.CompilerMode=cmMacPas) and (Scanner.PascalCompiler=pcFPC) and (CompareIdentifiers(PChar(Result),'MacPas')=0)) or ((Scanner.CompilerModeSwitch=cmsObjectiveC1) and ((CompareIdentifiers(PChar(Result),'ObjC')=0) or (CompareIdentifiers(PChar(Result),'ObjCBase')=0))) then begin Result:=''; exit; end; // check if already there UsesNode:=FindMainUsesSection; if (UsesNode<>nil) and (FindNameInUsesSection(UsesNode,Result)<>nil) then begin Result:=''; exit; end; UsesNode:=FindImplementationUsesSection; if (UsesNode<>nil) and (FindNameInUsesSection(UsesNode,Result)<>nil) then begin Result:=''; exit; end; // beautify if Result=lowercase(Result) then begin Alternative:=Tool.GetSourceName(false); if Alternative<>'' then Result:=Alternative; end; end; function TFindDeclarationTool.FindInitializationSection: TCodeTreeNode; begin Result:=Tree.Root; if Result=nil then exit; while (Result<>nil) and (Result.Desc<>ctnInitialization) do Result:=Result.NextBrother; end; function TFindDeclarationTool.FindDeclarationInUsesSection( UsesNode: TCodeTreeNode; CleanPos: integer; out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean; var AUnitName, UnitInFilename: string; UnitNamePos, UnitInFilePos: TAtomPosition; begin Result:=false; {$IFDEF ShowTriedContexts} DebugLn('TFindDeclarationTool.FindDeclarationInUsesSection A'); {$ENDIF} {$IFDEF CheckNodeTool}CheckNodeTool(UsesNode);{$ENDIF} // reparse uses section MoveCursorToNodeStart(UsesNode); if (UsesNode.Desc=ctnUsesSection) then begin ReadNextAtom; if not UpAtomIs('USES') then RaiseUsesExpected; end; repeat ReadNextAtom; // read name if CurPos.StartPos>CleanPos then break; if AtomIsChar(';') then break; AtomIsIdentifier(true); UnitNamePos:=CurPos; ReadNextAtom; if UpAtomIs('IN') then begin ReadNextAtom; if not AtomIsStringConstant then RaiseStrConstExpected; UnitInFilePos:=CurPos; ReadNextAtom; end else UnitInFilePos.StartPos:=-1; if CleanPos try to locate it AUnitName:=copy(Src,UnitNamePos.StartPos, UnitNamePos.EndPos-UnitNamePos.StartPos); if UnitInFilePos.StartPos>=1 then begin UnitInFilename:=copy(Src,UnitInFilePos.StartPos+1, UnitInFilePos.EndPos-UnitInFilePos.StartPos-2); end else UnitInFilename:=''; NewPos.Code:=FindUnitSource(AUnitName,UnitInFilename,true); if NewPos.Code=nil then RaiseExceptionInstance( ECodeToolUnitNotFound.Create(Self,Format(ctsUnitNotFound,[AUnitName]), AUnitName)); NewPos.X:=1; NewPos.Y:=1; NewTopLine:=1; Result:=true; exit; end; if AtomIsChar(';') then break; if not AtomIsChar(',') then RaiseExceptionFmt(ctsStrExpectedButAtomFound,[';',GetAtom]) until (CurPos.StartPos>SrcLen); {$IFDEF ShowTriedContexts} DebugLn('TFindDeclarationTool.FindDeclarationInUsesSection END cursor not on AUnitName'); {$ENDIF} end; function TFindDeclarationTool.FindUnitSource(const AnUnitName, AnUnitInFilename: string; ExceptionOnNotFound: boolean): TCodeBuffer; var CompiledFilename: string; AFilename: String; NewUnitName: String; NewInFilename: String; NewCompiledUnitname: String; begin {$IF defined(ShowTriedFiles) or defined(ShowTriedUnits)} DebugLn('TFindDeclarationTool.FindUnitSource Self="',MainFilename,'" AnUnitName="',AnUnitName,'" AnUnitInFilename="',AnUnitInFilename,'"'); {$ENDIF} Result:=nil; if (AnUnitName='') or (Scanner=nil) or (Scanner.MainCode=nil) or (not (TObject(Scanner.MainCode) is TCodeBuffer)) or (Scanner.OnLoadSource=nil) or (not CheckDirectoryCache) then begin RaiseException('TFindDeclarationTool.FindUnitSource Invalid Data'); end; NewUnitName:=AnUnitName; NewInFilename:=AnUnitInFilename; AFilename:=DirectoryCache.FindUnitSourceInCompletePath( NewUnitName,NewInFilename,false); Result:=TCodeBuffer(Scanner.OnLoadSource(Self,AFilename,true)); if (Result=nil) and Assigned(OnFindUsedUnit) then begin // no unit found Result:=OnFindUsedUnit(Self,AnUnitName,AnUnitInFilename); end; if Result=nil then begin // search .ppu NewCompiledUnitname:=AnUnitName+'.ppu'; CompiledFilename:=DirectoryCache.FindCompiledUnitInCompletePath( NewCompiledUnitname,false); end else begin CompiledFilename:=''; end; if (Result=nil) and ExceptionOnNotFound then begin if CompiledFilename<>'' then begin // there is a compiled unit, only the source was not found RaiseExceptionInstance( ECodeToolUnitNotFound.Create(Self, Format(ctsSourceNotFoundUnit, [CompiledFilename]),AnUnitName)); end else begin // nothing found RaiseExceptionInstance( ECodeToolUnitNotFound.Create(Self,Format(ctsUnitNotFound,[AnUnitName]), AnUnitName)); end; end; end; function TFindDeclarationTool.FindUnitCaseInsensitive(var AnUnitName, AnUnitInFilename: string): string; begin if not CheckDirectoryCache then exit(''); Result:=DirectoryCache.FindUnitSourceInCompletePath( AnUnitName,AnUnitInFilename,true); end; procedure TFindDeclarationTool.GatherUnitAndSrcPath(var UnitPath, CompleteSrcPath: string); begin UnitPath:=''; CompleteSrcPath:=''; if not CheckDirectoryCache then exit; UnitPath:=DirectoryCache.Strings[ctdcsUnitPath]; CompleteSrcPath:=DirectoryCache.Strings[ctdcsCompleteSrcPath]; //DebugLn('TFindDeclarationTool.GatherUnitAndSrcPath UnitPath="',UnitPath,'" CompleteSrcPath="',CompleteSrcPath,'"'); end; function TFindDeclarationTool.SearchUnitInUnitLinks(const TheUnitName: string ): string; begin Result:=''; if not CheckDirectoryCache then exit; Result:=DirectoryCache.FindUnitLink(TheUnitName); end; function TFindDeclarationTool.FindSmartHint(const CursorPos: TCodeXYPosition ): string; var NewTool: TFindDeclarationTool; NewNode, IdentNode, TypeNode, ANode: TCodeTreeNode; NewPos: TCodeXYPosition; NewTopLine: integer; AbsCursorPos: integer; IdentStartPos, IdentEndPos: integer; IdentAdded: boolean; ClassStr: String; NodeStr: String; begin Result:=''; if FindDeclaration(CursorPos,DefaultFindSmartFlags, NewTool,NewNode,NewPos,NewTopLine) then begin { Examples: var i: integer /home/.../codetools/finddeclarationtools.pas(1224,7) } IdentAdded:=false; // identifier category and identifier if NewNode<>nil then begin // class visibility if NewNode.Parent<>nil then begin ANode:=NewNode.Parent; while ANode<>nil do begin if ANode.Desc in AllClassSections then begin case ANode.Desc of ctnClassPrivate,ctnClassTypePrivate,ctnClassVarPrivate: Result:=Result+'private '; ctnClassProtected,ctnClassTypeProtected,ctnClassVarProtected: Result:=Result+'protected '; ctnClassPublic,ctnClassTypePublic,ctnClassVarPublic: Result:=Result+'public '; ctnClassPublished,ctnClassTypePublished,ctnClassVarPublished: Result:=Result+'published '; end; break; end else if ANode.Desc in ([ctnParameterList]+AllClasses) then break; ANode:=ANode.Parent; end; end; case NewNode.Desc of ctnVarDefinition, ctnTypeDefinition, ctnConstDefinition, ctnEnumIdentifier, ctnGenericType: begin case NewNode.Desc of ctnVarDefinition: Result:=Result+'var '; ctnTypeDefinition: Result:=Result+'type '; ctnConstDefinition: Result:=Result+'const '; ctnEnumIdentifier: Result:=Result+'enum '; ctnGenericType: Result:=Result+'generic type '; end; // add class name ClassStr := NewTool.ExtractClassName(NewNode, False); if ClassStr <> '' then Result := Result + ClassStr + '.'; Result:=Result+NewTool.ExtractDefinitionName(NewNode); IdentAdded:=true; TypeNode:=NewTool.FindTypeNodeOfDefinition(NewNode); if TypeNode<>nil then begin case TypeNode.Desc of ctnIdentifier, ctnClass, ctnClassInterface, ctnDispinterface, ctnObject, ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass: begin NewTool.MoveCursorToNodeStart(TypeNode); NewTool.ReadNextAtom; Result:=Result+': '+NewTool.GetAtom; end; ctnConstant: begin NodeStr:=' = '+NewTool.ExtractNode(TypeNode,[]); Result:=Result+copy(NodeStr,1,50); end; end; end else begin case NewNode.Desc of ctnConstDefinition: begin DebugLn('TFindDeclarationTool.FindSmartHint const without subnode "',NewTool.ExtractNode(NewNode,[]),'"'); NodeStr:=NewTool.ExtractCode(NewNode.StartPos +GetIdentLen(@NewTool.Src[NewNode.StartPos]), NewNode.EndPos,[]); Result:=Result+copy(NodeStr,1,50); end; end; end; end; ctnProcedure,ctnProcedureHead: begin // ToDo: ppu, ppw, dcu files Result:=Result+NewTool.ExtractProcHead(NewNode, [phpAddClassName,phpWithStart,phpWithVarModifiers,phpWithParameterNames, phpWithDefaultValues,phpWithResultType,phpWithOfObject]); IdentAdded:=true; end; ctnProperty, ctnProgram,ctnUnit,ctnPackage,ctnLibrary: begin IdentNode:=NewNode; // ToDo: ppu, ppw, dcu files NewTool.MoveCursorToNodeStart(IdentNode); NewTool.ReadNextAtom; Result:=Result+NewTool.GetAtom+' '; if NewNode.Desc = ctnProperty then begin // add class name ClassStr := NewTool.ExtractClassName(NewNode, False); if ClassStr <> '' then Result := Result + ClassStr + '.'; end; NewTool.ReadNextAtom; Result:=Result+NewTool.GetAtom+' '; IdentAdded:=true; end; ctnGlobalProperty: begin IdentNode:=NewNode; // ToDo: ppu, ppw, dcu files NewTool.MoveCursorToNodeStart(IdentNode); Result:=Result+'property '; NewTool.ReadNextAtom; Result:=Result+NewTool.GetAtom+' '; IdentAdded:=true; end; else DebugLn('ToDo: TFindDeclarationTool.FindSmartHint ',NewNode.DescAsString); end; end; // read the identifier if not already done if not IdentAdded then begin CursorPos.Code.LineColToPosition(CursorPos.Y,CursorPos.X,AbsCursorPos); GetIdentStartEndAtPosition(CursorPos.Code.Source, AbsCursorPos,IdentStartPos,IdentEndPos); if IdentStartPos'' then Result:=Result+LineEnding; Result:=Result+NewPos.Code.Filename; // file position if NewPos.Y>=1 then begin Result:=Result+'('+IntToStr(NewPos.Y); if NewPos.X>=1 then begin Result:=Result+','+IntToStr(NewPos.X); end; Result:=Result+')'; end; end; end; function TFindDeclarationTool.BaseTypeOfNodeHasSubIdents(ANode: TCodeTreeNode ): boolean; var FindContext: TFindContext; Params: TFindDeclarationParams; begin {$IFDEF CheckNodeTool}CheckNodeTool(ANode);{$ENDIF} Result:=false; if (ANode=nil) then exit; ActivateGlobalWriteLock; Params:=TFindDeclarationParams.Create; try Params.Flags:=Params.Flags+[fdfFunctionResult,fdfFindChilds]; FindContext:=FindBaseTypeOfNode(Params,ANode); if (FindContext.Node<>nil) and ((FindContext.Node.Desc in ([ctnRecordType,ctnEnumerationType]+AllClasses))) and (FindContext.Node.FirstChild<>nil) then Result:=true; finally Params.Free; DeactivateGlobalWriteLock; end; end; function TFindDeclarationTool.IsIncludeDirectiveAtPos(CleanPos, CleanCodePosInFront: integer; var IncludeCode: TCodeBuffer): boolean; var LinkIndex, CommentStart, CommentEnd: integer; SrcLink: TSourceLink; begin Result:=false; if (Scanner=nil) then exit; LinkIndex:=Scanner.LinkIndexAtCleanPos(CleanPos); if (LinkIndex<0) or (LinkIndex>=Scanner.LinkCount-1) then exit; SrcLink:=Scanner.Links[LinkIndex+1]; if (SrcLink.Code=nil) or (SrcLink.Code=Scanner.Links[LinkIndex].Code) then exit; //DebugLn(['TFindDeclarationTool.IsIncludeDirectiveAtPos CleanPos=',CleanPos,' CleanCodePosInFront=',CleanCodePosInFront,' ',copy(Src,CleanCodePosInFront,10)]); if CleanPosIsInComment(CleanPos,CleanCodePosInFront,CommentStart,CommentEnd) and (CommentEnd=SrcLink.CleanedPos) then begin //DebugLn(['TFindDeclarationTool.IsIncludeDirectiveAtPos CommentStart=',CommentStart,' CommentEnd=',CommentEnd,' ',copy(Src,CommentStart,CommentEnd-CommentStart)]); IncludeCode:=TCodeBuffer(SrcLink.Code); Result:=true; exit; end; end; function TFindDeclarationTool.FindDeclarationOfIdentAtParam( Params: TFindDeclarationParams): boolean; { searches an identifier in clean code, parses code in front and after the identifier Params: Identifier in clean source ContextNode // = DeepestNode at Cursor Result: true, if found Examples: A^.B().C[].Identifier inherited Identifier(p1,p2) } var StartPos, EndPos: integer; ExprType: TExpressionType; SkipForward: boolean; begin {$IFDEF CTDEBUG} DebugLn('[TFindDeclarationTool.FindDeclarationOfIdentAtParam] Identifier=', '"',GetIdentifier(Params.Identifier),'"', ' ContextNode=',NodeDescriptionAsString(Params.ContextNode.Desc), ' "',dbgstr(copy(Src,Params.ContextNode.StartPos,20)),'"'); {$ENDIF} Result:=false; // search in cleaned source MoveCursorToCleanPos(Params.Identifier); if Params.ContextNode.Desc<>ctnIdentifier then StartPos:=-1 else StartPos:=GetHybridCursorStart; ReadNextAtom; EndPos:=CurPos.EndPos; ReadNextAtom; if CurPos.Flag=cafRoundBracketOpen then begin ReadTilBracketClose(true); EndPos:=CurPos.EndPos; end; SkipForward:=fdfSkipClassForward in Params.Flags; Include(Params.Flags,fdfFindVariable); ExprType:=FindExpressionTypeOfTerm(StartPos,EndPos,Params,false); if (ExprType.Desc<>xtContext) then begin Params.SetResult(CleanFindContext); end; if SkipForward and (Params.NewNode<>nil) then Params.NewCodeTool.FindNonForwardClass(Params); {$IFDEF CTDEBUG} DbgOut('[TFindDeclarationTool.FindDeclarationOfIdentAtParam] Ident=', '"',GetIdentifier(Params.Identifier),'" '); if Params.NewNode<>nil then DebugLn('Node=',Params.NewNode.DescAsString,' ',Params.NewCodeTool.MainFilename) else DebugLn('NOT FOUND'); {$ENDIF} Result:=Params.NewNode<>nil; end; function TFindDeclarationTool.IdentifierIsDefined(IdentAtom: TAtomPosition; ContextNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean; var Identifier: PChar; Node: TCodeTreeNode; begin {$IFDEF CheckNodeTool}CheckNodeTool(ContextNode);{$ENDIF} // find declaration of identifier Identifier:=@Src[IdentAtom.StartPos]; //DebugLn(['TFindDeclarationTool.IdentifierIsDefined ',GetIdentifier(Identifier),' ',CompareIdentifiers(Identifier,'Result'),' ',]); if (CompareIdentifiers(Identifier,'Self')=0) then begin Node:=ContextNode; while (Node<>nil) do begin if NodeIsMethodBody(Node) then exit(true); Node:=Node.Parent; end; end; if (CompareIdentifiers(Identifier,'Result')=0) then begin Node:=ContextNode; while (Node<>nil) do begin if NodeIsFunction(Node) then exit(true); Node:=Node.Parent; end; end; Params.ContextNode:=ContextNode; Params.SetIdentifier(Self,Identifier,nil); Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors, fdfTopLvlResolving,fdfFindVariable,fdfIgnoreCurContextNode]; Result:=FindIdentifierInContext(Params); //DebugLn(['TFindDeclarationTool.IdentifierIsDefined END Result=',Result]); end; function TFindDeclarationTool.FindIdentifierInContext( Params: TFindDeclarationParams): boolean; { searches an identifier in context node It does not care about code in front of the identifier like 'a.Identifer'. Params: Identifier ContextNode // = DeepestNode at Cursor Result: true, if NewPos+NewTopLine valid } var LastContextNode, StartContextNode, FirstSearchedNode, LastSearchedNode, ContextNode: TCodeTreeNode; IsForward: boolean; OldParamFlags: TFindDeclarationFlags; IdentifierFoundResult: TIdentifierFoundResult; LastNodeCache: TCodeTreeNodeCache; LastCacheEntry: PCodeTreeNodeCacheEntry; SearchRangeFlags: TNodeCacheEntryFlags; NodeCacheEntryFlags: TNodeCacheEntryFlags; procedure InitNodesAndCacheAccess; procedure RaiseInternalError; begin RaiseException('[TFindDeclarationTool.FindIdentifierInContext] ' +' internal error: Params.ContextNode=nil'); end; begin ContextNode:=Params.ContextNode; if ContextNode=nil then RaiseInternalError; StartContextNode:=ContextNode; FirstSearchedNode:=nil; LastSearchedNode:=nil; SearchRangeFlags:=[]; if fdfSearchInParentNodes in Params.Flags then Include(SearchRangeFlags,ncefSearchedInParents); if fdfSearchInAncestors in Params.Flags then Include(SearchRangeFlags,ncefSearchedInAncestors); LastNodeCache:=nil; LastCacheEntry:=nil; NodeCacheEntryFlags:=[]; if fdfSearchInParentNodes in Params.Flags then Include(NodeCacheEntryFlags,ncefSearchedInParents); if fdfSearchInAncestors in Params.Flags then Include(NodeCacheEntryFlags,ncefSearchedInAncestors); end; function FindInNodeCache: boolean; var NodeCache: TCodeTreeNodeCache; begin Result:=false; // the node cache is identifier based if (fdfCollect in Params.Flags) then exit; NodeCache:=GetNodeCache(ContextNode,false); if (NodeCache<>LastNodeCache) then begin // NodeCache changed -> search nearest cache entry for the identifier LastNodeCache:=NodeCache; if NodeCache<>nil then begin LastCacheEntry:=NodeCache.FindNearest(Params.Identifier, ContextNode.StartPos,ContextNode.EndPos, not (fdfSearchForward in Params.Flags)); end else LastCacheEntry:=nil; end; if (LastCacheEntry<>nil) and (LastCacheEntry^.CleanStartPos<=ContextNode.StartPos) and (LastCacheEntry^.CleanEndPos>=ContextNode.EndPos) and ((NodeCacheEntryFlags-LastCacheEntry^.Flags)=[]) then begin // cached result found Params.SetResult(LastCacheEntry); {$IFDEF ShowNodeCache} DbgOut(':::: TFindDeclarationTool.FindIdentifierInContext.FindInNodeCache'); DebugLn(' Ident=',GetIdentifier(Params.Identifier), ' Wanted=[',NodeCacheEntryFlagsAsString(NodeCacheEntryFlags),']', ' Cache=[',NodeCacheEntryFlagsAsString(LastCacheEntry^.Flags),']' ); DebugLn(' ContextNode=',ContextNode.DescAsString, ' StartPos=',DbgS(ContextNode.StartPos), ' EndPos=',DbgS(ContextNode.EndPos), ' Self=',MainFilename); DebugLn(' LastCacheEntry(Pos=',DbgS(LastCacheEntry^.CleanStartPos), '-',DbgS(LastCacheEntry^.CleanEndPos),')'); if (Params.NewNode<>nil) then DebugLn(' NewTool=',Params.NewCodeTool.MainFilename, ' NewNode=',Params.NewNode.DescAsString) else DebugLn(' cache says: identifier does NOT exist'); if CompareSrcIdentifiers(Params.Identifier,'TDefineAction') then begin NodeCache.WriteDebugReport('NANUNANA: '); end; {$ENDIF} Result:=true; end; end; procedure CacheResult(Found: boolean; EndNode: TCodeTreeNode); begin if not Found then exit; FindIdentifierInContext:=true; if (FirstSearchedNode=nil) then exit; if ([fdfDoNotCache,fdfCollect]*Params.Flags<>[]) then exit; if ([fodDoNotCache]*Params.NewFlags<>[]) then exit; if (Params.OnIdentifierFound<>@CheckSrcIdentifier) then exit; if (Params.FoundProc<>nil) then exit; // do not cache proc searches // cache result if (Params.NewNode<>nil) and (Params.NewNode.Desc=ctnProcedure) then begin DebugLn('NOTE: TFindDeclarationTool.FindIdentifierInContext.CacheResult Node is proc'); // ToDo: // The search range is from start to end of search. // This does not work for overloaded procs. // -> do not cache exit; end; AddResultToNodeCaches(FirstSearchedNode,EndNode, fdfSearchForward in Params.Flags,Params,SearchRangeFlags); end; function CheckResult(NewResult, CallOnIdentifierFound: boolean): boolean; // returns: true to stop search // false if search should continue procedure RaiseNotFound; var Identifier: string; begin Identifier:=GetIdentifier(Params.Identifier); if (Identifier='') and (Params.Identifier<>nil) and (Params.Identifier[0]<>#0) then begin Identifier:=Params.Identifier[0]; if Identifier='[' then begin Params.IdentifierTool.RaiseException(ctsDefaultPropertyNotFound); end; end; Params.IdentifierTool.RaiseExceptionFmt(ctsIdentifierNotFound, [Identifier]); end; var IdentFoundResult: TIdentifierFoundResult; begin Result:=true; FindIdentifierInContext:=NewResult; {$IFDEF ShowCollect} if fdfCollect in Params.Flags then begin DebugLn('[TFindDeclarationTool.FindIdentifierInContext.CheckResult] COLLECT CheckResult Ident=', '"',GetIdentifier(Params.Identifier),'"', ' File="',ExtractFilename(MainFilename)+'"', ' Flags=[',FindDeclarationFlagsAsString(Params.Flags)+']', ' NewResult=',DbgS(NewResult), ' CallOnIdentifierFound=',DbgS(CallOnIdentifierFound)); end; {$ENDIF} if NewResult then begin // identifier found if CallOnIdentifierFound then begin { debugln('[TFindDeclarationTool.FindIdentifierInContext.CheckResult] CallOnIdentifierFound Ident=', '"',GetIdentifier(Params.Identifier),'"', ' StartContext="',StartContextNode.DescAsString,'" "',copy(Src,StartContextNode.StartPos,20),'"', ' File="',ExtractFilename(MainFilename)+'"', ' Flags=[',FindDeclarationFlagsAsString(Params.Flags),']' ); } IdentFoundResult:=Params.NewCodeTool.DoOnIdentifierFound(Params, Params.NewNode); {$IFDEF ShowProcSearch} DebugLn(['[TFindDeclarationTool.FindIdentifierInContext.CheckResult] DoOnIdentifierFound=',IdentifierFoundResultNames[IdentFoundResult]]); {$ENDIF} if (IdentFoundResult=ifrSuccess) then CacheResult(true,ContextNode); Result:=IdentFoundResult<>ifrProceedSearch; if IdentFoundResult<>ifrAbortSearch then exit; end else begin if fdfCollect in Params.Flags then Result:=false; CacheResult(true,ContextNode); exit; end; end; if Params.FoundProc<>nil then begin // there was a proc, // either the search for the overloaded proc was unsuccessful // or the searched proc was found in a recursive sub search // -> return the found proc if Params.FoundProc^.CacheValid and (Params.FoundProc^.ProcCompatibility=tcExact) then begin // stop the search Result:=true; end; FindIdentifierInContext:=true; Params.SetResult(Params.FoundProc^.Context.Tool, Params.FoundProc^.Context.Node); {$IFDEF ShowProcSearch} DebugLn('[TFindDeclarationTool.FindIdentifierInContext] PROC Search ended with only one proc (normal when searching every used unit):'); Params.WriteDebugReport; {$ENDIF} exit; end; // identifier was not found if not (fdfExceptionOnNotFound in Params.Flags) then exit; if (Params.Identifier<>nil) and not (fdfExceptionOnPredefinedIdent in Params.Flags) and WordIsPredefinedIdentifier.DoItCaseInsensitive(Params.Identifier) then begin Params.SetResult(nil,nil); exit; end; // identifier was not found and exception is wanted // -> raise exception if Params.IdentifierTool.IsPCharInSrc(Params.Identifier) then Params.IdentifierTool.MoveCursorToCleanPos(Params.Identifier); RaiseNotFound; end; procedure MoveContextNodeToChilds; begin if ContextNode.Desc in AllClasses then begin // just-in-time parsing for class node BuildSubTreeForClass(ContextNode); end; if (ContextNode.LastChild<>nil) then begin if not (fdfSearchForward in Params.Flags) then begin RaiseLastErrorIfInFrontOfCleanedPos(ContextNode.EndPos); ContextNode:=ContextNode.LastChild; end else ContextNode:=ContextNode.FirstChild; end; end; function SearchInGenericParams(GenericNode: TCodeTreeNode): boolean; var Node: TCodeTreeNode; begin Result:=false; Node:=GenericNode.FirstChild; if Node=nil then exit; Node:=Node.NextBrother; if (Node=nil) or (Node.Desc<>ctnGenericParams) then exit; Node:=Node.FirstChild; while Node<>nil do begin if (fdfCollect in Params.Flags) or CompareSrcIdentifiers(Node.StartPos,Params.Identifier) then begin {$IFDEF ShowTriedIdentifiers} DebugLn(' SearchInGenericParams Identifier found="',GetIdentifier(Params.Identifier),'"'); {$ENDIF} // identifier found Params.SetResult(Self,Node); Result:=CheckResult(true,true); if not (fdfCollect in Params.Flags) then exit; end; Node:=Node.NextBrother; end; end; function SearchInTypeVarConstPropDefinition: boolean; // returns: true if ok to exit // false if search should continue var NameNode: TCodeTreeNode; begin Result:=false; //DebugLn(' SearchInTypeVarConstPropDefinition Identifier "',GetIdentifier(Params.Identifier),'" ',ExtractDefinitionName(ContextNode)); NameNode:=ContextNode; if ContextNode.Desc=ctnGenericType then begin NameNode:=ContextNode.FirstChild; if NameNode=nil then exit; end; if (fdfCollect in Params.Flags) or CompareSrcIdentifiers(NameNode.StartPos,Params.Identifier) then begin {$IFDEF ShowTriedIdentifiers} DebugLn(' Definition Identifier found="',GetIdentifier(Params.Identifier),'"'); {$ENDIF} // identifier found Params.SetResult(Self,ContextNode); Result:=CheckResult(true,true); if not (fdfCollect in Params.Flags) then begin if (fdfSkipClassForward in Params.Flags) and (ContextNode.FirstChild<>nil) and (ContextNode.FirstChild.Desc in AllClasses) and ((ctnsForwardDeclaration and ContextNode.FirstChild.SubDesc)<>0) then begin FindNonForwardClass(Params); end; exit; end; end; // search for enums Params.ContextNode:=ContextNode; if FindEnumInContext(Params) then begin Result:=CheckResult(true,false); end; end; function SearchInEnumDefinition: boolean; // returns: true if ok to exit // false if search should continue begin Result:=false; if (fdfCollect in Params.Flags) or CompareSrcIdentifiers(ContextNode.StartPos,Params.Identifier) then begin {$IFDEF ShowTriedIdentifiers} DebugLn(' Enum Identifier found="',GetIdentifier(Params.Identifier),'"'); {$ENDIF} // identifier found Params.SetResult(Self,ContextNode); Result:=CheckResult(true,true); if not (fdfCollect in Params.Flags) then begin exit; end; end; end; function SearchInOnBlockDefinition: boolean; begin Result:=false; if ContextNode.FirstChild=nil then exit; //debugln('SearchInOnBlockDefinition B ',GetIdentifier(@Src[ContextNode.StartPos])); if (fdfCollect in Params.Flags) or CompareSrcIdentifiers(ContextNode.FirstChild.StartPos,Params.Identifier) then begin {$IFDEF ShowTriedIdentifiers} DebugLn(' ON Identifier found="',GetIdentifier(Params.Identifier),'"'); {$ENDIF} // identifier found Params.SetResult(Self,ContextNode.FirstChild); Result:=CheckResult(true,true); if not (fdfCollect in Params.Flags) then exit; end; end; function SearchInSourceName: boolean; // returns: true if ok to exit // false if search should continue begin Result:=false; MoveCursorToNodeStart(ContextNode); ReadNextAtom; // read keyword ReadNextAtom; // read name if (fdfCollect in Params.Flags) or CompareSrcIdentifiers(CurPos.StartPos,Params.Identifier) then begin // identifier found {$IFDEF ShowTriedIdentifiers} DebugLn(' Source Name Identifier found="',GetIdentifier(Params.Identifier),'"'); {$ENDIF} Params.SetResult(Self,ContextNode,CurPos.StartPos); Result:=CheckResult(true,true); if not (fdfCollect in Params.Flags) then exit; end; if (not (fdfIgnoreUsedUnits in Params.Flags)) and FindIdentifierInHiddenUsedUnits(Params) then begin Result:=CheckResult(true,false); end; end; function SearchInProperty: boolean; // returns: true if ok to exit // false if search should continue begin Result:=false; if (fdfCollect in Params.Flags) or (Params.Identifier[0]<>'[') then begin MoveCursorToNodeStart(ContextNode); if (ContextNode.Desc=ctnProperty) then begin ReadNextAtom; // read keyword 'property' if UpAtomIs('CLASS') then ReadNextAtom; end; ReadNextAtom; // read name if (fdfCollect in Params.Flags) or CompareSrcIdentifiers(CurPos.StartPos,Params.Identifier) then begin // identifier found {$IFDEF ShowTriedIdentifiers} DebugLn(' Property Identifier found="',GetIdentifier(Params.Identifier),'"'); {$ENDIF} Params.SetResult(Self,ContextNode,CurPos.StartPos); Result:=CheckResult(true,true); end; end else begin // the default property is searched if PropertyIsDefault(ContextNode) then begin Params.SetResult(Self,ContextNode); Result:=CheckResult(true,true); end; end; end; function LeavingContextIsPermitted: boolean; begin Result:=true; if (not ContextNode.HasAsParent(StartContextNode)) then begin // searching in a prior node, will leave the start context if (not (fdfSearchInParentNodes in Params.Flags)) then begin // searching in any parent context is not permitted if not ((fdfSearchInAncestors in Params.Flags) and (ContextNode.Desc in AllClasses)) then begin // even searching in ancestors contexts is not permitted // -> there is no prior context accessible any more // -> identifier not found {$IFDEF ShowTriedContexts} DebugLn('[TFindDeclarationTool.FindIdentifierInContext] no prior node accessible ', ' ContextNode=',ContextNode.DescAsString, ' "',StringToPascalConst(copy(Src,ContextNode.StartPos,15)),'"' ); {$ENDIF} ContextNode:=nil; Result:=false; end; end; end; end; function SearchNextNode: boolean; begin repeat // search for prior node {$IFDEF ShowTriedIdentifiers} DebugLn('[TFindDeclarationTool.FindIdentifierInContext] Searching prior node of ',ContextNode.DescAsString,' ',dbgstr(copy(Src,ContextNode.StartPos,ContextNode.EndPos-ContextNode.StartPos))); {$ENDIF} LastSearchedNode:=ContextNode; if (ContextNode.Parent<>nil) and (ContextNode.Parent.Desc=ctnGenericType) then begin // after search in the generic, search in the generic parameter names if SearchInGenericParams(ContextNode.Parent) then begin FindIdentifierInContext:=true; Result:=false; exit; end; end; if (ContextNode.Desc in AllClasses) and (fdfSearchInAncestors in Params.Flags) then begin // after searching in a class definiton, search in its ancestors // ToDo: check for circles in ancestors OldParamFlags:=Params.Flags; Exclude(Params.Flags,fdfExceptionOnNotFound); Result:=FindIdentifierInAncestors(ContextNode,Params); Params.Flags:=OldParamFlags; if Result then begin FindIdentifierInContext:=true; Result:=false; exit; end; end; if (ContextNode=StartContextNode) and (not (fdfSearchInParentNodes in Params.Flags)) then begin // startcontext completed => not searching in parents or ancestors ContextNode:=nil; break; end; if ((not (fdfSearchForward in Params.Flags)) and (ContextNode.PriorBrother<>nil)) or ((fdfSearchForward in Params.Flags) and (ContextNode.NextBrother<>nil) and (ContextNode.NextBrother.Desc<>ctnImplementation)) then begin // search next in prior/next brother if not (fdfSearchForward in Params.Flags) then ContextNode:=ContextNode.PriorBrother else begin RaiseLastErrorIfInFrontOfCleanedPos(ContextNode.NextBrother.EndPos); ContextNode:=ContextNode.NextBrother; end; {$IFDEF ShowTriedIdentifiers} DebugLn('[TFindDeclarationTool.FindIdentifierInContext] Searching in Brother ContextNode=',ContextNode.DescAsString); {$ENDIF} // it is not always allowed to search in every node on the same lvl: // -> test if class visibility valid if ContextNode.Desc in AllClassSections then break else if ContextNode.Desc=ctnWithVariable then begin // check if StartContextNode is covered by the ContextNode // a WithVariable ranges from the start of its expression // to the end of the with statement {$IFDEF ShowExprEval} DebugLn('SearchNextNode WithVar StartContextNode.StartPos=',dbgs(StartContextNode.StartPos), ' ContextNode=',dbgs(ContextNode.StartPos),'-',dbgs(ContextNode.EndPos), ' WithStart="',StringToPascalConst(copy(Src,ContextNode.StartPos,15)),'"'); {$ENDIF} if (StartContextNode.StartPos>=ContextNode.StartPos) and (StartContextNode.StartPos skip it for example: will be skipped: with ContextNode do ; with B do StartContextNode; will be searched: with ContextNode, StartContextNode do ; } end else begin break; end; end else if (ContextNode.Parent<>nil) and ((fdfSearchInParentNodes in Params.Flags) or (ContextNode.HasAsParent(StartContextNode))) then begin // search next in parent {$IFDEF ShowTriedParentContexts} DebugLn('[TFindDeclarationTool.FindIdentifierInContext] Searching in Parent ', ' old ContextNode=',ContextNode.DescAsString, ' new ContextNode=',ContextNode.Parent.DescAsString ); {$ENDIF} ContextNode:=ContextNode.Parent; case ContextNode.Desc of ctnTypeSection, ctnVarSection, ctnConstSection, ctnResStrSection, ctnLabelSection, ctnPropertySection, ctnInterface, ctnImplementation, ctnClassPublished,ctnClassPublic,ctnClassProtected,ctnClassPrivate, ctnClassTypePublished,ctnClassTypePublic,ctnClassTypeProtected,ctnClassTypePrivate, ctnClassVarPublished,ctnClassVarPublic,ctnClassVarProtected,ctnClassVarPrivate, ctnRecordVariant, ctnProcedureHead, ctnParameterList, ctnClassInheritance: // these codetreenodes build a parent-child-relationship, but // for pascal it is only a range, hence after searching in the // childs of the last node, search must continue in the childs // of the prior node ; ctnClass, ctnClassInterface, ctnDispinterface, ctnObject, ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass, ctnRecordType, ctnRecordCase, ctnEnumerationType: // do not search again in this node, go on ... ; ctnVarDefinition, ctnConstDefinition: if (ContextNode.Parent<>nil) and (ContextNode.Parent.Desc=ctnParameterList) then begin // pascal allows declarations like: 'var a: a;' in parameters // -> skip variable and search in next context node ; end else begin break; end; ctnProcedure: begin Result:=FindIdentifierInClassOfMethod(ContextNode,Params); if Result then begin FindIdentifierInContext:=true; Result:=false; exit; end; end; else break; end; end else begin ContextNode:=nil; break; end; until false; Result:=true; end; begin Result:=false; InitNodesAndCacheAccess; {$IFDEF ShowTriedContexts} DebugLn('[TFindDeclarationTool.FindIdentifierInContext] Start Ident=', '"'+GetIdentifier(Params.Identifier)+'"', ' Context="'+ContextNode.DescAsString+'" "'+StringToPascalConst(copy(Src,ContextNode.StartPos,20)),'"', ' File="'+ExtractFilename(MainFilename)+'"', ' Flags=['+FindDeclarationFlagsAsString(Params.Flags)+']' ); {$ELSE} {$IFDEF ShowCollect} if fdfCollect in Params.Flags then begin DebugLn(['[TFindDeclarationTool.FindIdentifierInContext] COLLECT Start Ident=', '"',GetIdentifier(Params.Identifier),'"', ' Context="',ContextNode.DescAsString,'" "',copy(Src,ContextNode.StartPos,20),'"', ' File="',ExtractFilename(MainFilename)+'"', ' Flags=[',FindDeclarationFlagsAsString(Params.Flags),']' ]); end; {$ENDIF} {$ENDIF} if (ContextNode.Desc=ctnInterface) and (fdfIgnoreUsedUnits in Params.Flags) then begin {$IFDEF ShowTriedContexts} DebugLn(['TFindDeclarationTool.FindIdentifierInContext searching in interface of ',MainFilename]); {$ENDIF} Result:=FindIdentifierInInterface(Params.IdentifierTool,Params); CheckResult(Result,false); exit; end; //try // search in the Tree of this tool repeat {$IFDEF ShowTriedIdentifiers} DebugLn('[TFindDeclarationTool.FindIdentifierInContext] Loop Ident=', '"',GetIdentifier(Params.Identifier),'"', ' Context="',ContextNode.DescAsString,'" "',copy(Src,ContextNode.StartPos,20),'"', ' Flags=[',FindDeclarationFlagsAsString(Params.Flags),']' ); {$ELSE} {$IFDEF ShowCollect} if fdfCollect in Params.Flags then begin DebugLn('[TFindDeclarationTool.FindIdentifierInContext] COLLECT Loop Ident=', '"',GetIdentifier(Params.Identifier),'"', ' Context="',ContextNode.DescAsString,'" "',copy(Src,ContextNode.StartPos,20),'"', ' Flags=[',FindDeclarationFlagsAsString(Params.Flags),']' ); end; {$ENDIF} {$ENDIF} // search identifier in current context LastContextNode:=ContextNode; if not (fdfIgnoreCurContextNode in Params.Flags) then begin // search in cache if FindInNodeCache then begin if CheckResult(Params.NewNode<>nil,Params.NewNode<>nil) then exit; end; if FirstSearchedNode=nil then FirstSearchedNode:=ContextNode; LastSearchedNode:=ContextNode; case ContextNode.Desc of ctnTypeSection, ctnVarSection, ctnConstSection, ctnResStrSection, ctnLabelSection, ctnPropertySection, ctnInterface, ctnImplementation, ctnClassPublic, ctnClassPrivate, ctnClassProtected, ctnClassPublished, ctnClassTypePublished,ctnClassTypePublic,ctnClassTypeProtected,ctnClassTypePrivate, ctnClassVarPublished,ctnClassVarPublic,ctnClassVarProtected,ctnClassVarPrivate, ctnClass, ctnClassInterface, ctnDispinterface, ctnObject, ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass, ctnRecordType, ctnRecordVariant, ctnEnumerationType, ctnParameterList: // these nodes build a parent-child relationship. But in pascal // they just define a range and not a context. // -> search in all childs MoveContextNodeToChilds; ctnTypeDefinition, ctnVarDefinition, ctnConstDefinition, ctnGlobalProperty, ctnGenericType: if SearchInTypeVarConstPropDefinition then exit; ctnEnumIdentifier: if SearchInEnumDefinition then exit; ctnProcedure: begin IdentifierFoundResult:= FindIdentifierInProcContext(ContextNode,Params); if IdentifierFoundResult in [ifrAbortSearch,ifrSuccess] then begin if CheckResult(IdentifierFoundResult=ifrSuccess,true) then begin {$IFDEF ShowProcSearch} DebugLn(['TFindDeclarationTool.FindIdentifierInContext ctnProcedure FOUND, stopping']); {$ENDIF} exit; end; {$IFDEF ShowProcSearch} DebugLn(['TFindDeclarationTool.FindIdentifierInContext ctnProcedure FOUND, continue']); {$ENDIF} end; end; ctnProcedureHead: begin BuildSubTreeForProcHead(ContextNode); if ContextNode.FirstChild<>nil then ContextNode:=ContextNode.FirstChild; // the ctnParameterList end; ctnProgram, ctnPackage, ctnLibrary, ctnUnit: if SearchInSourceName then exit; ctnProperty: if SearchInProperty then exit; ctnUsesSection: begin if FindIdentifierInUsesSection(ContextNode,Params) and CheckResult(true,false) then exit; end; ctnWithVariable: begin if FindIdentifierInWithVarContext(ContextNode,Params) and CheckResult(true,false) then exit; end; ctnOnBlock: if SearchInOnBlockDefinition then exit; ctnPointerType: begin // pointer types can be forward definitions // -> search in both directions Params.ContextNode:=ContextNode.Parent; if CheckResult(FindForwardIdentifier(Params,IsForward),false) then exit; end; ctnRecordCase: begin if FindIdentifierInRecordCase(ContextNode,Params) and CheckResult(true,true) then exit; // search in variants MoveContextNodeToChilds; end; end; end else begin Exclude(Params.Flags,fdfIgnoreCurContextNode); {$IFDEF ShowTriedContexts} DebugLn('[TFindDeclarationTool.FindIdentifierInContext] IgnoreCurContext '); {$ENDIF} end; if LastContextNode=ContextNode then begin // same context -> search in prior context if not LeavingContextIsPermitted then break; if not SearchNextNode then exit; end; until ContextNode=nil; {except // unexpected exception on E: Exception do begin DebugLn('*** Unexpected Exception during find declaration: ', E.ClassName,': ',E.Message); DebugLn(' MainFilename=',MainFilename); raise; end; end;} // if we are here, the identifier was not found and there was no error if (FirstSearchedNode<>nil) and (Params.FoundProc=nil) and (not (fdfCollect in Params.Flags)) then begin // add result to cache Params.NewNode:=nil; Params.NewCodeTool:=nil; AddResultToNodeCaches(FirstSearchedNode,LastSearchedNode, fdfSearchForward in Params.Flags,Params,SearchRangeFlags); end; CheckResult(false,false); end; function TFindDeclarationTool.FindEnumInContext( Params: TFindDeclarationParams): boolean; { search all subnodes for ctnEnumIdentifier Params: Identifier ContextNode // = DeepestNode at Cursor Result: true, if enum found } var OldContextNode, CurContextNode: TCodeTreeNode; CollectResult: TIdentifierFoundResult; begin Result:=false; if Params.ContextNode=nil then exit; CurContextNode:=Params.ContextNode; if CurContextNode.Desc in AllClasses then BuildSubTreeForClass(CurContextNode); CurContextNode:=CurContextNode.FirstChild; while CurContextNode<>nil do begin if (CurContextNode.Desc=ctnEnumIdentifier) then begin if (fdfCollect in Params.Flags) then begin //debugln('TFindDeclarationTool.FindEnumInContext ',GetIdentifier(@Src[CurContextNode.StartPos])); CollectResult:=DoOnIdentifierFound(Params,CurContextNode); if CollectResult=ifrAbortSearch then begin Result:=false; exit; end else if CollectResult=ifrSuccess then begin Result:=true; Params.SetResult(Self,CurContextNode); exit; end; end else if CompareSrcIdentifiers(CurContextNode.StartPos,Params.Identifier) then begin // identifier found Result:=true; Params.SetResult(Self,CurContextNode); exit; end; end; OldContextNode:=Params.ContextNode; if OldContextNode.FirstChild<>nil then begin Params.ContextNode:=CurContextNode; Result:=FindEnumInContext(Params); Params.ContextNode:=OldContextNode; if Result then exit; end; CurContextNode:=CurContextNode.NextBrother; end; end; function TFindDeclarationTool.FindContextNodeAtCursor( Params: TFindDeclarationParams): TFindContext; { searches for the context node at a specific cursor pos Params.Context should contain the deepest node at cursor if there is no special context, then result is equal to Params.Context } var EndPos: integer; ExprType: TExpressionType; OldFlags: TFindDeclarationFlags; begin EndPos:=CurPos.StartPos; OldFlags:=Params.Flags; Params.Flags:=Params.Flags-[fdfFindVariable]; ExprType:=FindExpressionTypeOfTerm(-1,EndPos,Params,false); Params.Flags:=OldFlags; if (ExprType.Desc=xtContext) then Result:=ExprType.Context else begin if fdfExceptionOnNotFound in Params.Flags then begin MoveCursorToCleanPos(EndPos); RaiseException(ctsNoContextNodeFoundAtCursor); end else begin Result:=CleanFindContext; end; end; end; function TFindDeclarationTool.FindBaseTypeOfNode(Params: TFindDeclarationParams; Node: TCodeTreeNode): TFindContext; procedure RaiseForwardClassNameLess; begin RaiseException('[TFindDeclarationTool.FindBaseTypeOfNode] ' +'forward class node without name'); end; procedure RaiseCircleDefs; begin Params.NewCodeTool.RaiseException(ctsCircleInDefinitions +' ('+ctsIdentifier+'='+GetIdentifier(Params.Identifier)+')'); end; procedure RaiseInternalError; begin Params.IdentifierTool.RaiseException( '[TFindDeclarationTool.FindBaseTypeOfNode]' +' internal error: not IsPCharInSrc(Params.Identifier) ' +' Params.IdentifierTool.=' +TCodeBuffer(Params.IdentifierTool.Scanner.MainCode).Filename +' Ident="'+GetIdentifier(Params.Identifier)+'"'); end; procedure RaiseBaseTypeOfNotFound; begin RaiseExceptionFmt(ctsBaseTypeOfNotFound,[GetIdentifier(Params.Identifier)]); end; procedure RaiseClassOfWithoutIdentifier; begin RaiseExceptionFmt(ctsBaseTypeOfNotFound+' ("class of")', [GetIdentifier(Params.Identifier)]); end; var OldInput: TFindDeclarationInput; ClassIdentNode, DummyNode: TCodeTreeNode; NodeStack: TCodeTreeNodeStack; OldPos: integer; TypeFound: boolean; SpecializeNode: TCodeTreeNode; TypeNode: TCodeTreeNode; NameNode: TCodeTreeNode; procedure RaiseForwardNotResolved; begin RaiseExceptionFmt(ctsForwardClassDefinitionNotResolved, [copy(Src,ClassIdentNode.StartPos, ClassIdentNode.EndPos-ClassIdentNode.StartPos)]); end; procedure RaiseClassOfNotResolved; begin MoveCursorToNodeStart(ClassIdentNode); RaiseExceptionFmt(ctsClassOfDefinitionNotResolved, [copy(Src,ClassIdentNode.StartPos, ClassIdentNode.EndPos-ClassIdentNode.StartPos)]); end; begin {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF} Result.Node:=Node; Result.Tool:=Self; Exclude(Params.Flags,fdfTopLvlResolving); InitializeNodeStack(@NodeStack); try while (Result.Node<>nil) do begin if (Result.Node.Cache<>nil) and (Result.Node.Cache is TBaseTypeCache) then begin // base type already cached Result:=CreateFindContext(TBaseTypeCache(Result.Node.Cache)); exit; end; if NodeExistsInStack(@NodeStack,Result.Node) then begin // circle detected Result.Tool.MoveCursorToNodeStart(Result.Node); Result.Tool.RaiseException(ctsCircleInDefinitions); end; AddNodeToStack(@NodeStack,Result.Node); {$IFDEF ShowTriedBaseContexts} DebugLn('[TFindDeclarationTool.FindBaseTypeOfNode] LOOP Result=',Result.Node.DescAsString,' ',DbgS(Result.Node)); DebugLn(' Flags=[',FindDeclarationFlagsAsString(Params.Flags),']'); {$ENDIF} if (Result.Node.Desc in AllIdentifierDefinitions) then begin // instead of variable/const/type definition, return the type DummyNode:=Result.Tool.FindTypeNodeOfDefinition(Result.Node); if DummyNode=nil then // some constants and variants do not have a type break; Result.Node:=DummyNode; end else if (Result.Node.Desc in AllClasses) and ((Result.Node.SubDesc and ctnsForwardDeclaration)>0) then begin // this is a forward defined class // -> search the real class {$IFDEF ShowTriedBaseContexts} DebugLn('[TFindDeclarationTool.FindBaseTypeOfNode] Class is forward'); {$ENDIF} // ToDo: check for circles in ancestor chain ClassIdentNode:=Result.Node.Parent; if (ClassIdentNode=nil) or (not (ClassIdentNode.Desc in [ctnTypeDefinition,ctnGenericType])) then begin MoveCursorToCleanPos(Result.Node.StartPos); RaiseForwardClassNameLess; end; Params.Save(OldInput); Params.SetIdentifier(Self,@Src[ClassIdentNode.StartPos], @CheckSrcIdentifier); Params.Flags:=[fdfSearchInParentNodes,fdfSearchForward, fdfIgnoreUsedUnits,fdfExceptionOnNotFound, fdfIgnoreCurContextNode] +(fdfGlobals*Params.Flags); Params.ContextNode:=ClassIdentNode; FindIdentifierInContext(Params); if (not (Params.NewNode.Desc in [ctnTypeDefinition,ctnGenericType])) or (Params.NewCodeTool<>Self) then begin MoveCursorToCleanPos(Result.Node.StartPos); RaiseForwardNotResolved; end; Result:=Params.NewCodeTool.FindBaseTypeOfNode(Params,Params.NewNode); Params.Load(OldInput,true); exit; end else if (Result.Node.Desc=ctnClassOfType) and (fdfFindChilds in Params.Flags) then begin // this is a 'class of' type // -> search the real class {$IFDEF ShowTriedBaseContexts} DebugLn('[TFindDeclarationTool.FindBaseTypeOfNode] "Class Of"'); {$ENDIF} // ToDo: check for circles in ancestor chain ClassIdentNode:=Result.Node.FirstChild; if (ClassIdentNode=nil) or (not (ClassIdentNode.Desc=ctnIdentifier)) then begin MoveCursorToCleanPos(Result.Node.StartPos); RaiseClassOfWithoutIdentifier; end; Params.Save(OldInput); // first search backwards Params.SetIdentifier(Self,@Src[ClassIdentNode.StartPos], @CheckSrcIdentifier); Params.Flags:=[fdfSearchInParentNodes, fdfIgnoreCurContextNode] +(fdfGlobals*Params.Flags)-[fdfExceptionOnNotFound]; Params.ContextNode:=Result.Node.Parent; if not FindIdentifierInContext(Params) then begin // then search forwards Params.Load(OldInput,false); Params.SetIdentifier(Self,@Src[ClassIdentNode.StartPos], @CheckSrcIdentifier); Params.Flags:=[fdfSearchInParentNodes,fdfExceptionOnNotFound, fdfIgnoreCurContextNode,fdfSearchForward] +(fdfGlobals*Params.Flags); Params.ContextNode:=Result.Node.Parent; FindIdentifierInContext(Params); end; if not (Params.NewNode.Desc in [ctnTypeDefinition,ctnGenericType]) then begin MoveCursorToCleanPos(Result.Node.StartPos); RaiseClassOfNotResolved; end; Result:=Params.NewCodeTool.FindBaseTypeOfNode(Params,Params.NewNode); Params.Load(OldInput,true); exit; end else if (Result.Node.Desc=ctnOnIdentifier) and (Result.Node.PriorBrother=nil) then begin // this is the ON variable node, the type comes right behind Result.Node:=Result.Node.NextBrother; end else if (Result.Node.Desc in [ctnIdentifier,ctnOnIdentifier]) then begin // this type is just an alias for another type // -> search the basic type if Result.Node.Parent=nil then break; Params.Save(OldInput); DummyNode:=Result.Node; Params.SetIdentifier(Self,@Src[Result.Node.StartPos], @CheckSrcIdentifier); Params.Flags:=[fdfSearchInParentNodes,fdfExceptionOnNotFound] +(fdfGlobals*Params.Flags); Params.ContextNode:=Result.Node.Parent; if (Params.ContextNode.Desc in [ctnVarDefinition,ctnConstDefinition]) then begin // pascal allows things like 'var a: a;' -> skip var definition Include(Params.Flags,fdfIgnoreCurContextNode); end; if Params.ContextNode.Desc=ctnParameterList then // skip search in parameter list Params.ContextNode:=Params.ContextNode.Parent; if Params.ContextNode.Desc=ctnProcedureHead then // skip search in proc parameters Params.ContextNode:=Params.ContextNode.Parent; TypeFound:=FindIdentifierInContext(Params); if TypeFound and (Params.NewNode.Desc in [ctnUseUnit,ctnUsesSection]) then begin NameNode:=Params.NewNode; Params.NewNode:=nil; Params.NewCodeTool:=FindCodeToolForUnitIdentifier(NameNode, GetIdentifier(Params.Identifier),true); Params.NewCodeTool.BuildTree(true); Params.NewNode:=Params.NewCodeTool.Tree.Root; end; if TypeFound and (Params.NewNode.Desc in [ctnUnit,ctnLibrary,ctnPackage]) then begin // AUnitName.typename MoveCursorToNodeStart(Result.Node); ReadNextAtom; // read AUnitName if not ReadNextAtomIsChar('.') then RaiseCharExpectedButAtomFound('.'); ReadNextAtom; // read type identifier AtomIsIdentifier(true); Params.Load(OldInput,false); Params.SetIdentifier(Self,@Src[CurPos.StartPos], @CheckSrcIdentifier); Params.Flags:=[fdfExceptionOnNotFound] +(fdfGlobals*OldInput.Flags); Params.ContextNode:=Params.NewCodeTool.FindInterfaceNode; TypeFound:=Params.NewCodeTool.FindIdentifierInContext(Params); end; if TypeFound then begin // only types allowed here if Params.NewNode.Desc=ctnTypeDefinition then begin if NodeExistsInStack(@NodeStack,Params.NewNode) then begin // circle detected Params.NewCodeTool.MoveCursorToNodeStart(Params.NewNode); RaiseCircleDefs; end; Result:=Params.NewCodeTool.FindBaseTypeOfNode(Params, Params.NewNode); end else if Params.NewNode.Desc=ctnGenericParameter then begin Result.Tool:=Params.NewCodeTool; Result.Node:=Params.NewNode; end else begin // not a type MoveCursorToNodeStart(DummyNode); ReadNextAtom; RaiseExceptionFmt(ctsStrExpectedButAtomFound, [ctsTypeIdentifier,GetAtom]); end; end else // predefined identifier Result:=CreateFindContext(Self,Result.Node); Params.Load(OldInput,true); exit; end else if (Result.Node.Desc=ctnProperty) or (Result.Node.Desc=ctnGlobalProperty) then begin // this is a property -> search the type definition of the property if MoveCursorToPropType(Result.Node) then begin AtomIsIdentifier(true); OldPos:=CurPos.StartPos; ReadNextAtom; if CurPos.Flag=cafPoint then begin // unit.type ReadNextAtom; AtomIsIdentifier(true); OldPos:=CurPos.StartPos; ReadNextAtom; end; // property has type Params.Save(OldInput); Params.SetIdentifier(Self,@Src[OldPos],nil); Params.Flags:=[fdfSearchInParentNodes,fdfExceptionOnNotFound] +(fdfGlobals*Params.Flags); Params.ContextNode:=Result.Node.Parent; if FindIdentifierInContext(Params) then begin // only types allowed if Params.NewNode.Desc=ctnTypeDefinition then begin if NodeExistsInStack(@NodeStack,Params.NewNode) then begin // circle detected Params.NewCodeTool.MoveCursorToNodeStart(Params.NewNode); RaiseCircleDefs; end; Result:=Params.NewCodeTool.FindBaseTypeOfNode(Params, Params.NewNode) end else if Params.NewNode.Desc=ctnGenericParameter then begin Result.Tool:=Params.NewCodeTool; Result.Node:=Params.NewNode; end else begin // not a type MoveCursorToCleanPos(OldPos); ReadNextAtom; RaiseExceptionFmt(ctsStrExpectedButAtomFound, [ctsTypeIdentifier,GetAtom]); end; end else // predefined identifier Result:=CreateFindContext(Self,Result.Node); Params.Load(OldInput,true); exit; end else if (Result.Node.Desc=ctnProperty) then begin // property has no type // -> search ancestor property Params.Save(OldInput); if not MoveCursorToPropName(Result.Node) then exit; OldPos:=CurPos.StartPos; Params.SetIdentifier(Self,@Src[CurPos.StartPos],nil); Params.Flags:=[fdfExceptionOnNotFound,fdfSearchInAncestors] +(fdfGlobalsSameIdent*Params.Flags); FindIdentifierInAncestors(Result.Node.Parent.Parent,Params); if Params.NewNode.Desc=ctnProperty then begin Result:=Params.NewCodeTool.FindBaseTypeOfNode(Params, Params.NewNode); end else begin // ancestor is not a property MoveCursorToCleanPos(OldPos); RaiseException(ctsAncestorIsNotProperty); end; Params.Load(OldInput,true); exit; end; end else if (Result.Node.Desc in [ctnProcedure,ctnProcedureHead]) and (fdfFunctionResult in Params.Flags) then begin // a proc -> if this is a function then return the result type if Result.Node.Desc=ctnProcedure then Result.Node:=Result.Node.FirstChild; BuildSubTreeForProcHead(Result.Node,DummyNode); if (DummyNode<>nil) then begin // a function or an overloaded operator Result.Node:=DummyNode; Exclude(Params.Flags,fdfFunctionResult); end else begin // this is a procedure or destructor break; end; end else if (Result.Node.Desc=ctnTypeType) then begin // a TypeType is for example 'MyInt = type integer;' // the context is not the 'type' keyword, but the identifier after it. Result.Node:=Result.Node.FirstChild; end else if (Result.Node.Desc=ctnEnumIdentifier) then begin // an enum identifier if fdfEnumIdentifier in Params.Flags then break; // the enum is wanted, not its type // an enum identifier, the base type is the enumeration Result.Node:=Result.Node.Parent; end else if (Result.Node.Desc=ctnSpecialize) then begin // go to the type name of the specialisation SpecializeNode:=Result.Node; TypeNode:=SpecializeNode.Parent; NameNode:=SpecializeNode.FirstChild; Result.Node:=NameNode; if Result.Node=nil then break; Params.Save(OldInput); Params.SetIdentifier(Self,@Src[NameNode.StartPos], @CheckSrcIdentifier); Params.Flags:=[fdfSearchInParentNodes,fdfExceptionOnNotFound, fdfIgnoreCurContextNode] +(fdfGlobals*Params.Flags); Params.ContextNode:=TypeNode; TypeFound:=FindIdentifierInContext(Params); if TypeFound and (Params.NewNode.Desc in [ctnUnit,ctnLibrary,ctnPackage]) then begin // AUnitName.typename MoveCursorToNodeStart(NameNode); ReadNextAtom; // read AUnitName if not ReadNextAtomIsChar('.') then RaiseCharExpectedButAtomFound('.'); ReadNextAtom; // read type identifier AtomIsIdentifier(true); Params.Load(OldInput,false); Params.SetIdentifier(Self,@Src[CurPos.StartPos], @CheckSrcIdentifier); Params.Flags:=[fdfExceptionOnNotFound] +(fdfGlobals*OldInput.Flags); Params.ContextNode:=Params.NewCodeTool.FindInterfaceNode; TypeFound:=Params.NewCodeTool.FindIdentifierInContext(Params); end; if not TypeFound then begin Result.Node:=nil; break; end; if Params.NewNode.Desc<>ctnGenericType then begin // not a generic MoveCursorToNodeStart(NameNode); ReadNextAtom; RaiseExceptionFmt(ctsStrExpectedButAtomFound, [ctsGenericIdentifier,GetAtom]); end; if NodeExistsInStack(@NodeStack,Params.NewNode) then begin // circle detected Params.NewCodeTool.MoveCursorToNodeStart(Params.NewNode); RaiseCircleDefs; end; Result.Tool:=Params.NewCodeTool; Result.Node:=Result.Tool.FindTypeNodeOfDefinition(Params.NewNode); Params.Load(OldInput,true); exit; end else break; end; if (Result.Node=nil) and (fdfExceptionOnNotFound in Params.Flags) then begin if (Result.Tool<>nil) and (Params.Identifier<>nil) then begin // ToDo ppu, ppw, dcu if (not Params.IdentifierTool.IsPCharInSrc(Params.Identifier)) then RaiseInternalError; Params.IdentifierTool.MoveCursorToCleanPos(Params.Identifier); end; RaiseBaseTypeOfNotFound; end; finally // cache the result in all nodes CreateBaseTypeCaches(@NodeStack,Result); // free node stack FinalizeNodeStack(@NodeStack); end; {$IFDEF ShowFoundIdentifier} DbgOut('[TFindDeclarationTool.FindBaseTypeOfNode] END Node='); if Node<>nil then DbgOut(Node.DescAsString) else DbgOut('NIL'); DbgOut(' Result='); if Result.Node<>nil then DbgOut(Result.Node.DescAsString) else DbgOut('NIL'); DebugLn(''); {$ENDIF} end; function TFindDeclarationTool.FindDeclarationAndOverload( const CursorPos: TCodeXYPosition; out ListOfPCodeXYPosition: TFPList; Flags: TFindDeclarationListFlags): boolean; var CurCursorPos: TCodeXYPosition; NewTool: TFindDeclarationTool; NewNode: TCodeTreeNode; NewPos: TCodeXYPosition; NewTopLine: integer; CurTool: TFindDeclarationTool; OldPositions: TFPList; NodeList: TFPList; CleanPos: integer; AtDefinition: Boolean; procedure AddPos; begin AddCodePosition(OldPositions,NewPos); if (NodeList.IndexOf(NewNode)>=0) then exit; NodeList.Add(NewNode); if (fdlfWithoutEmptyProperties in Flags) and (NewNode.Desc=ctnProperty) and (NewTool.PropNodeIsTypeLess(NewNode)) then exit; if (fdlfWithoutForwards in Flags) then begin if (NewNode.Desc in [ctnTypeDefinition,ctnGenericType]) and NewTool.NodeIsForwardDeclaration(NewNode) then exit; if (NewNode.Desc=ctnProcedure) and ((NewNode.SubDesc and ctnsForwardDeclaration)>0) then exit; end; AddCodePosition(ListOfPCodeXYPosition,NewPos); end; function StartPositionAtDefinition: boolean; begin if (NewNode.Desc in AllIdentifierDefinitions) and (PositionInDefinitionName(NewNode,CleanPos)) then Result:=true else if (NewNode.Desc in [ctnProcedure,ctnProcedureHead]) and (PositionInProcName(NewNode,false,CleanPos)) then Result:=true else if (NewNode.Desc=ctnProperty) and (PositionInPropertyName(NewNode,CleanPos)) then Result:=true else if (NewNode.Desc in AllSourceTypes) and (PositionInSourceName(CleanPos)) then Result:=true else Result:=false; end; function StartPositionAtFunctionResult: boolean; var Node: TCodeTreeNode; begin Result:=false; if (NewNode.Desc in [ctnProcedureHead,ctnIdentifier]) and PositionInFuncResultName(NewNode,CleanPos) then begin Node:=NewNode; if Node.Desc=ctnProcedureHead then begin Node:=Node.FirstChild; if Node=nil then exit; if Node.Desc=ctnParameterList then Node:=Node.NextBrother; if Node=nil then exit; end; if Node.Desc in [ctnVarDefinition,ctnIdentifier] then begin // return the function result type or the operator variable name NewNode:=Node; Result:=true; end; end; end; begin Result:=true; ListOfPCodeXYPosition:=nil; NewTool:=nil; NewNode:=nil; OldPositions:=nil; NodeList:=nil; ActivateGlobalWriteLock; try BuildTreeAndGetCleanPos(trTillCursorSection,CursorPos,CleanPos,[]); NodeList:=TFPList.Create; NewTool:=Self; NewNode:=BuildSubTreeAndFindDeepestNodeAtPos(CleanPos,true); NewPos:=CursorPos; AtDefinition:=StartPositionAtDefinition; if AtDefinition then begin AddPos; if fdlfIfStartIsDefinitionStop in Flags then exit; end; if StartPositionAtFunctionResult then begin AddPos; // the function result has no overloads => stop search exit; end; if NewNode.Desc in AllSourceTypes then begin // the unit name has no overloads => stop search exit; end; CurCursorPos:=CursorPos; CurTool:=Self; try while CurTool.FindDeclaration(CurCursorPos,DefaultFindSmartFlags +[fsfSearchSourceName], NewTool,NewNode,NewPos,NewTopLine) do begin if IndexOfCodePosition(OldPositions,@NewPos)>=0 then break; AddPos; CurCursorPos:=NewPos; CurTool:=NewTool; {debugln('TFindDeclarationTool.FindDeclarationAndOverload Self="',MainFilename,'" '); if CurCursorPos.Code<>nil then debugln(' CurCursorPos=',CurCursorPos.Code.Filename,' ',dbgs(CurCursorPos.X),',',dbgs(CurCursorPos.Y)); if CurTool<>nil then debugln(' CurTool=',CurTool.MainFilename);} if (CurTool=nil) then exit; end; except // ignore normal errors on E: ECodeToolError do ; on E: ELinkScannerError do ; end; finally FreeListOfPCodeXYPosition(OldPositions); NodeList.Free; DeactivateGlobalWriteLock; end; end; function TFindDeclarationTool.FindClassAndAncestors(ClassNode: TCodeTreeNode; out ListOfPFindContext: TFPList): boolean; var FoundContext: TFindContext; CurTool: TFindDeclarationTool; Params: TFindDeclarationParams; begin {$IFDEF CheckNodeTool}CheckNodeTool(ClassNode);{$ENDIF} Result:=false; ListOfPFindContext:=nil; if (ClassNode=nil) or (not (ClassNode.Desc in AllClasses)) or (ClassNode.Parent=nil) or (not (ClassNode.Parent.Desc in [ctnTypeDefinition,ctnGenericType])) then exit; AddFindContext(ListOfPFindContext,CreateFindContext(Self,ClassNode)); Params:=TFindDeclarationParams.Create; ActivateGlobalWriteLock; try try CurTool:=Self; while CurTool.FindAncestorOfClass(ClassNode,Params,true) do begin if (Params.NewCodeTool=nil) then break; FoundContext.Tool:=Params.NewCodeTool; FoundContext.Node:=Params.NewNode; if IndexOfFindContext(ListOfPFindContext,@FoundContext)>=0 then break; AddFindContext(ListOfPFindContext,FoundContext); //debugln('TFindDeclarationTool.FindClassAndAncestors FoundContext=',DbgsFC(FoundContext)); CurTool:=Params.NewCodeTool; ClassNode:=Params.NewNode; if (ClassNode=nil) or (not (ClassNode.Desc in AllClasses)) then break; end; Result:=true; except // catch syntax errors on E: ECodeToolError do ; on E: ELinkScannerError do ; end; finally DeactivateGlobalWriteLock; Params.Free; end; end; function TFindDeclarationTool.FindContextClassAndAncestors( const CursorPos: TCodeXYPosition; var ListOfPFindContext: TFPList ): boolean; // returns a list of nodes of AllClasses (ctnClass, ...) var CleanCursorPos: integer; ANode: TCodeTreeNode; ClassNode: TCodeTreeNode; begin Result:=false; ListOfPFindContext:=nil; ActivateGlobalWriteLock; try BuildTreeAndGetCleanPos(trTillCursor,CursorPos,CleanCursorPos, [{$IFNDEF DisableIgnoreErrorAfter}btSetIgnoreErrorPos{$ENDIF}]); // find class node ANode:=FindDeepestNodeAtPos(CleanCursorPos,true); if (ANode.GetNodeOfType(ctnClassInheritance)<>nil) then exit; ClassNode:=FindClassNode(ANode); if (ClassNode=nil) or (ClassNode.Parent=nil) or (not (ClassNode.Parent.Desc in [ctnTypeDefinition,ctnGenericType])) then exit; //debugln('TFindDeclarationTool.FindContextClassAndAncestors A ClassName=',ExtractClassName(ClassNode,false)); // add class and ancestors type definition to ListOfPCodeXYPosition if not FindClassAndAncestors(ClassNode,ListOfPFindContext) then exit; //debugln('TFindDeclarationTool.FindContextClassAndAncestors List: ',ListOfPFindContextToStr(ListOfPFindContext)); finally DeactivateGlobalWriteLock; end; Result:=true; end; {------------------------------------------------------------------------------- function TFindDeclarationTool.FindReferences(const CursorPos: TCodeXYPosition; SkipComments: boolean; var ListOfPCodeXYPosition: TFPList): boolean; Search for all identifiers in current unit, referring to the declaration at CursorPos. -------------------------------------------------------------------------------} function TFindDeclarationTool.FindReferences(const CursorPos: TCodeXYPosition; SkipComments: boolean; out ListOfPCodeXYPosition: TFPList): boolean; var Identifier: string; DeclarationTool: TFindDeclarationTool; DeclarationNode: TCodeTreeNode; CleanDeclCursorPos: integer; AliasDeclarationNode: TCodeTreeNode; StartPos: Integer; Params: TFindDeclarationParams; PosTree: TAVLTree; // tree of PChar positions in Src AVLNode: TAVLTreeNode; ReferencePos: TCodeXYPosition; MaxPos: Integer; CursorNode: TCodeTreeNode; UnitStartFound, Found: Boolean; procedure AddReference; var p: PChar; begin if PosTree=nil then PosTree:=TAVLTree.Create; p:=@Src[StartPos]; //debugln('TFindDeclarationTool.FindReferences.AddReference ',DbgS(p),' ',dbgs(PosTree.Find(p)=nil)); if PosTree.Find(p)=nil then PosTree.Add(p); end; procedure AddCodePosition(const NewCodePos: TCodeXYPosition); var AddCodePos: PCodeXYPosition; begin if ListOfPCodeXYPosition=nil then ListOfPCodeXYPosition:=TFPList.Create; New(AddCodePos); AddCodePos^:=NewCodePos; ListOfPCodeXYPosition.Add(AddCodePos); //debugln('TFindDeclarationTool.FindReferences.AddCodePosition line=',dbgs(NewCodePos.Y),' col=',dbgs(NewCodePos.X)); end; procedure ReadIdentifier(IsComment: boolean); var IdentEndPos: LongInt; begin if (not IsComment) then begin UnitStartFound:=true; end; IdentEndPos:=StartPos; while (IdentEndPos<=MaxPos) and (IsIdentChar[Src[IdentEndPos]]) do inc(IdentEndPos); //debugln('ReadIdentifier ',copy(Src,StartPos,IdentEndPos-StartPos)); if (IdentEndPos-StartPos=length(Identifier)) and (CompareIdentifiers(PChar(Pointer(Identifier)),@Src[StartPos])=0) and ((not IsComment) or ((not SkipComments) and UnitStartFound)) then begin {debugln('Identifier with same name found at: ', dbgs(StartPos),' ',GetIdentifier(@Src[StartPos]), ' CleanDeclCursorPos=',dbgs(CleanDeclCursorPos), ' MaxPos='+dbgs(MaxPos), ' IsComment='+dbgs(IsComment), ' SkipComments='+dbgs(SkipComments), ' UnitStartFound='+dbgs(UnitStartFound)); if CleanPosToCaret(StartPos,ReferencePos) then debugln(' x=',dbgs(ReferencePos.X),' y=',dbgs(ReferencePos.Y),' ',ReferencePos.Code.Filename);} CursorNode:=BuildSubTreeAndFindDeepestNodeAtPos(StartPos,true); //debugln(' CursorNode=',CursorNode.DescAsString,' Forward=',dbgs(CursorNode.SubDesc and ctnsForwardDeclaration)); if (DeclarationTool=Self) and ((StartPos=CleanDeclCursorPos) or (CursorNode=AliasDeclarationNode)) then // declaration itself found AddReference else if CleanPosIsDeclarationIdentifier(StartPos,CursorNode) then // this identifier is another declaration with the same name else begin // find declaration if Params=nil then Params:=TFindDeclarationParams.Create else Params.Clear; Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors, fdfExceptionOnNotFound,fdfIgnoreCurContextNode]; if NodeIsForwardDeclaration(CursorNode) then begin //debugln('Node is forward declaration'); Params.Flags:=Params.Flags+[fdfSearchForward]; end; Params.ContextNode:=CursorNode; //debugln(copy(Src,Params.ContextNode.StartPos,200)); Params.SetIdentifier(Self,@Src[StartPos],@CheckSrcIdentifier); // search identifier in comment -> if not found, this is no bug // => silently ignore try if fdfSearchForward in Params.Flags then Found:=FindIdentifierInContext(Params) else Found:=FindDeclarationOfIdentAtParam(Params); except on E: ECodeToolError do if not IsComment then raise; on E: Exception do raise; end; //debugln(' Found=',dbgs(Found)); if Found and (Params.NewNode<>nil) then begin if (Params.NewNode.Desc=ctnProcedure) and (Params.NewNode.FirstChild<>nil) and (Params.NewNode.FirstChild.Desc=ctnProcedureHead) then begin // Instead of jumping to the procedure keyword, // jump to the procedure name Params.NewNode:=Params.NewNode.FirstChild; Params.NewCodeTool.MoveCursorToProcName(Params.NewNode,true); Params.NewCleanPos:=Params.NewCodeTool.CurPos.StartPos; end; //debugln('Context=',Params.NewNode.DescAsString,' ',dbgs(Params.NewNode.StartPos),' ',dbgs(DeclarationNode.StartPos)); if (Params.NewNode=DeclarationNode) or (Params.NewNode=AliasDeclarationNode) then AddReference; end; end; end; StartPos:=IdentEndPos; end; procedure SearchIdentifiers; var CommentLvl: Integer; InStrConst: Boolean; //CommentStart: LongInt; begin StartPos:=1; UnitStartFound:=false; while StartPos<=MaxPos do begin case Src[StartPos] of '{': // pascal comment begin //CommentStart:=StartPos; inc(StartPos); CommentLvl:=1; InStrConst:=false; while StartPos<=MaxPos do begin case Src[StartPos] of '{': if Scanner.NestedComments then inc(CommentLvl); '}': begin dec(CommentLvl); if CommentLvl=0 then break; end; 'a'..'z','A'..'Z','_': if not InStrConst then begin ReadIdentifier(true); dec(StartPos); end; '''': InStrConst:=not InStrConst; end; inc(StartPos); end; inc(StartPos); //debugln(StartPos,' ',copy(Src,CommentStart,StartPos-CommentStart)); end; '/': // Delphi comment if (Src[StartPos+1]<>'/') then begin inc(StartPos); end else begin inc(StartPos,2); InStrConst:=false; while (StartPos<=MaxPos) do begin case Src[StartPos] of #10,#13: break; 'a'..'z','A'..'Z','_': if not InStrConst then begin ReadIdentifier(true); dec(StartPos); end; '''': InStrConst:=not InStrConst; end; inc(StartPos); end; inc(StartPos); if (StartPos<=MaxPos) and (Src[StartPos] in [#10,#13]) and (Src[StartPos-1]<>Src[StartPos]) then inc(StartPos); end; '(': // turbo pascal comment if (Src[StartPos+1]<>'*') then begin inc(StartPos); end else begin inc(StartPos,3); InStrConst:=false; while (StartPos<=MaxPos) do begin case Src[StartPos] of ')': if Src[StartPos-1]='*' then break; 'a'..'z','A'..'Z','_': if not InStrConst then begin ReadIdentifier(true); dec(StartPos); end; '''': InStrConst:=not InStrConst; end; inc(StartPos); end; inc(StartPos); end; 'a'..'z','A'..'Z','_': ReadIdentifier(false); '''': begin // skip string constant inc(StartPos); while (StartPos<=MaxPos) do begin if (not (Src[StartPos] in ['''',#10,#13])) then inc(StartPos) else begin inc(StartPos); break; end; end; end; else inc(StartPos); end; end; end; function FindDeclarationNode: boolean; const JumpToProcAttr = [phpInUpperCase,phpWithoutClassName,phpWithVarModifiers]; var ProcNode: TCodeTreeNode; begin Result:=false; // find the main declaration node and identifier DeclarationTool:=nil; if Assigned(FOnGetCodeToolForBuffer) then DeclarationTool:=FOnGetCodeToolForBuffer(Self,CursorPos.Code,true) else if CursorPos.Code=TObject(Scanner.MainCode) then DeclarationTool:=Self; if DeclarationTool=nil then begin debugln('WARNING: TFindDeclarationTool.FindReferences DeclarationTool=nil'); exit; end; DeclarationTool.BuildTreeAndGetCleanPos(trAll,CursorPos,CleanDeclCursorPos, []); DeclarationNode:=DeclarationTool.BuildSubTreeAndFindDeepestNodeAtPos( CleanDeclCursorPos,true); Identifier:=DeclarationTool.ExtractIdentifier(CleanDeclCursorPos); if Identifier='' then begin debugln('FindDeclarationNode Identifier="',Identifier,'"'); exit; end; // find alias declaration node //debugln('FindDeclarationNode DeclarationNode=',DeclarationNode.DescAsString); AliasDeclarationNode:=nil; case DeclarationNode.Desc of ctnProcedure: AliasDeclarationNode:=DeclarationTool.FindCorrespondingProcNode( DeclarationNode,JumpToProcAttr); ctnProcedureHead: AliasDeclarationNode:=DeclarationTool.FindCorrespondingProcNode( DeclarationNode.Parent,JumpToProcAttr); ctnVarDefinition: if DeclarationNode.HasParentOfType(ctnProcedureHead) then begin // this is a parameter name ProcNode:=DeclarationNode.GetNodeOfType(ctnProcedure); // search alias for parameter ProcNode:=DeclarationTool.FindCorrespondingProcNode(ProcNode,JumpToProcAttr); if ProcNode<>nil then begin DeclarationTool.BuildSubTreeForProcHead(ProcNode); AliasDeclarationNode:=ProcNode; while (AliasDeclarationNode<>nil) do begin if AliasDeclarationNode.Desc in [ctnProcedure,ctnProcedureHead,ctnParameterList] then AliasDeclarationNode:=AliasDeclarationNode.FirstChild else begin if CompareIdentifiers(PChar(Pointer(Identifier)), @DeclarationTool.Src[AliasDeclarationNode.StartPos])=0 then break; AliasDeclarationNode:=AliasDeclarationNode.NextBrother; end; end; end; end; end; if (AliasDeclarationNode<>nil) and (AliasDeclarationNode.Desc=ctnProcedure) and (AliasDeclarationNode.FirstChild<>nil) and (AliasDeclarationNode.FirstChild.Desc=ctnProcedureHead) then AliasDeclarationNode:=AliasDeclarationNode.FirstChild; if AliasDeclarationNode<>nil then begin //debugln('FindDeclarationNode AliasDeclarationNode=',AliasDeclarationNode.DescAsString); end; Result:=true; end; begin Result:=false; //debugln('FindReferences CursorPos=',CursorPos.Code.Filename,' x=',dbgs(CursorPos.X),' y=',dbgs(CursorPos.Y),' SkipComments=',dbgs(SkipComments)); ListOfPCodeXYPosition:=nil; Params:=nil; PosTree:=nil; ActivateGlobalWriteLock; try BuildTree(false); // find declaration nodes and identifier if not FindDeclarationNode then exit; // search identifiers MaxPos:=Tree.FindLastPosition; if MaxPos>SrcLen then MaxPos:=SrcLen; //debugln('FindReferences StartPos=',dbgs(StartPos),' MaxPos=',dbgs(MaxPos)); SearchIdentifiers; // create the reference list if PosTree<>nil then begin AVLNode:=PosTree.FindHighest; while AVLNode<>nil do begin StartPos:=PChar(AVLNode.Data)-PChar(Pointer(Src))+1; if CleanPosToCaret(StartPos,ReferencePos) then AddCodePosition(ReferencePos); AVLNode:=PosTree.FindPrecessor(AVLNode); end; end; finally Params.Free; PosTree.Free; DeactivateGlobalWriteLock; end; Result:=true; end; function TFindDeclarationTool.FindUnitReferences(UnitCode: TCodeBuffer; SkipComments: boolean; out ListOfPCodeXYPosition: TFPList): boolean; var AUnitName, UpperUnitName: String; function CheckUsesSection(UsesNode: TCodeTreeNode; out Found: boolean): boolean; var ReferencePos: TCodeXYPosition; begin Result:=true; Found:=false; if UsesNode=nil then exit; //DebugLn(['CheckUsesSection ']); MoveCursorToNodeStart(UsesNode); if (UsesNode.Desc=ctnUsesSection) then begin ReadNextAtom; if not UpAtomIs('USES') then RaiseUsesExpected; end; repeat ReadNextAtom; // read name if CurPos.StartPos>SrcLen then break; if AtomIsChar(';') then break; AtomIsIdentifier(true); //DebugLn(['CheckUsesSection ',GetAtom,' ',AUnitName]); if UpAtomIs(UpperUnitName) then begin // compare case insensitive if CleanPosToCaret(CurPos.StartPos,ReferencePos) then begin //DebugLn(['CheckUsesSection found in uses section: ',DbgsCXY(ReferencePos)]); Found:=true; AddCodePosition(ListOfPCodeXYPosition,ReferencePos); end; end; ReadNextAtom; if UpAtomIs('IN') then begin ReadNextAtom; if not AtomIsStringConstant then RaiseStrConstExpected; ReadNextAtom; end; if AtomIsChar(';') then break; if not AtomIsChar(',') then RaiseExceptionFmt(ctsStrExpectedButAtomFound,[';',GetAtom]) until (CurPos.StartPos>SrcLen); end; function CheckSource(StartPos: integer): boolean; var ReferencePos: TCodeXYPosition; begin MoveCursorToCleanPos(StartPos); repeat ReadNextAtom; if UpAtomIs(UpperUnitName) and not LastAtomIs(0,'.') then begin if CleanPosToCaret(CurPos.StartPos,ReferencePos) then begin //DebugLn(['CheckSource found: ',DbgsCXY(ReferencePos)]); AddCodePosition(ListOfPCodeXYPosition,ReferencePos); end; end; until CurPos.StartPos>SrcLen; Result:=true; end; var InterfaceUsesNode: TCodeTreeNode; ImplementationUsesNode: TCodeTreeNode; Found: boolean; StartPos: Integer; begin Result:=false; //debugln('FindUnitReferences UnitCode=',UnitCode.Filename,' SkipComments=',dbgs(SkipComments),' ',MainFilename); AUnitName:=ExtractFileNameOnly(UnitCode.Filename); UpperUnitName:=UpperCaseStr(AUnitName); ListOfPCodeXYPosition:=nil; ActivateGlobalWriteLock; try BuildTree(false); InterfaceUsesNode:=FindMainUsesSection; if not CheckUsesSection(InterfaceUsesNode,Found) then exit; StartPos:=-1; if Found then begin StartPos:=InterfaceUsesNode.EndPos; end else begin ImplementationUsesNode:=FindImplementationUsesSection; if not CheckUsesSection(ImplementationUsesNode,Found) then exit; if Found then StartPos:=ImplementationUsesNode.EndPos; end; // find unit reference in source if StartPos>0 then begin if not CheckSource(StartPos) then exit; end; finally DeactivateGlobalWriteLock; end; Result:=true; end; {------------------------------------------------------------------------------- function TFindDeclarationTool.CleanPosIsDeclarationIdentifier(CleanPos: integer; Node: TCodeTreeNode): boolean; Node should be the deepest node at CleanPos, and all sub trees built. See BuildSubTree -------------------------------------------------------------------------------} function TFindDeclarationTool.CleanPosIsDeclarationIdentifier(CleanPos: integer; Node: TCodeTreeNode): boolean; function InNodeIdentifier(NodeIdentStartPos: Integer): boolean; var IdentStartPos, IdentEndPos: integer; begin GetIdentStartEndAtPosition(Src,CleanPos,IdentStartPos,IdentEndPos); Result:=(IdentEndPos>IdentStartPos) and (IdentStartPos=NodeIdentStartPos); end; begin {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF} Result:=false; if Node=nil then exit; case Node.Desc of ctnTypeDefinition,ctnVarDefinition,ctnConstDefinition,ctnEnumIdentifier: begin if NodeIsForwardDeclaration(Node) then exit; Result:=InNodeIdentifier(Node.StartPos); end; ctnGenericType: begin if (Node.FirstChild=nil) or NodeIsForwardDeclaration(Node) then exit; Result:=InNodeIdentifier(Node.FirstChild.StartPos); end; ctnProcedure: begin if (Node.SubDesc and ctnsForwardDeclaration)>0 then RaiseException('TFindDeclarationTool.CleanPosIsDeclarationIdentifier Node not expanded'); MoveCursorToProcName(Node,true); Result:=InNodeIdentifier(CurPos.StartPos); end; ctnProcedureHead: begin MoveCursorToProcName(Node,true); Result:=InNodeIdentifier(CurPos.StartPos); end; ctnProperty, ctnGlobalProperty: begin if not MoveCursorToPropName(Node) then exit; Result:=InNodeIdentifier(CurPos.StartPos); end; ctnBeginBlock,ctnClass,ctnObject,ctnObjCClass,ctnObjCCategory,ctnCPPClass: if (Node.SubDesc and ctnsForwardDeclaration)>0 then RaiseException('TFindDeclarationTool.CleanPosIsDeclarationIdentifier Node not expanded'); end; end; function TFindDeclarationTool.JumpToNode(ANode: TCodeTreeNode; out NewPos: TCodeXYPosition; out NewTopLine: integer; IgnoreJumpCentered: boolean): boolean; var JumpPos: LongInt; begin {$IFDEF CheckNodeTool}CheckNodeTool(ANode);{$ENDIF} Result:=false; if (ANode=nil) or (ANode.StartPos<1) then exit; JumpPos:=ANode.StartPos; if ANode.Desc=ctnProperty then begin MoveCursorToPropName(ANode); JumpPos:=CurPos.StartPos; end; Result:=JumpToCleanPos(JumpPos,JumpPos,ANode.EndPos, NewPos,NewTopLine,IgnoreJumpCentered); end; function TFindDeclarationTool.JumpToCleanPos(NewCleanPos, NewTopLineCleanPos, NewBottomLineCleanPos: integer; out NewPos: TCodeXYPosition; out NewTopLine: integer; IgnoreJumpCentered: boolean): boolean; var CenteredTopLine: integer; NewTopLinePos: TCodeXYPosition; NewBottomLinePos: TCodeXYPosition; begin Result:=false; // convert clean position to line, column and code if not CleanPosToCaret(NewCleanPos,NewPos) then exit; NewTopLine:=NewPos.Y; if AdjustTopLineDueToComment then begin // if there is a comment in front of the top position, it probably belongs // to the destination code // -> adjust the topline position, so that the comment is visible NewTopLineCleanPos:=FindLineEndOrCodeInFrontOfPosition(NewTopLineCleanPos, false); if (NewTopLineCleanPos>=1) and (Src[NewTopLineCleanPos] in [#13,#10]) then begin inc(NewTopLineCleanPos); if (Src[NewTopLineCleanPos] in [#10,#13]) and (Src[NewTopLineCleanPos]<>Src[NewTopLineCleanPos-1]) then inc(NewTopLineCleanPos); end; end; // convert clean top line position to line, column and code if not CleanPosToCaret(NewTopLineCleanPos,NewTopLinePos) then exit; // convert clean bottom line position to line, column and code NewBottomLinePos:=NewPos; if (NewBottomLineCleanPos>NewCleanPos) and (not CleanPosToCaret(NewBottomLineCleanPos,NewBottomLinePos)) then exit; if NewTopLinePos.Code=NewPos.Code then begin // top line position is in the same code as the destination position NewTopLine:=NewTopLinePos.Y; CenteredTopLine:=NewPos.Y-VisibleEditorLines div 2; if JumpCentered and (not IgnoreJumpCentered) then begin // center the destination position in the source editor if CenteredTopLineNewCleanPos) and (NewBottomLinePos.Y0 then begin Result:=true; exit; end; end; end; function TFindDeclarationTool.FindIdentifierInProcContext( ProcContextNode: TCodeTreeNode; Params: TFindDeclarationParams): TIdentifierFoundResult; { this function is internally used by FindIdentifierInContext } var NameAtom: TAtomPosition; begin {$IFDEF CheckNodeTool}CheckNodeTool(ProcContextNode);{$ENDIF} Result:=ifrProceedSearch; // if proc is a method body, search in class // -> find class name if ProcContextNode.FirstChild=nil then exit(ifrProceedSearch); MoveCursorToNodeStart(ProcContextNode.FirstChild); ReadNextAtom; // read name if not AtomIsIdentifier(false) then exit; // ignore operator procs NameAtom:=CurPos; ReadNextAtom; if AtomIsChar('.') then begin // proc is a method body (not a declaration). // -> proceed the search normally ... end else begin // proc is a proc declaration if ((fdfCollect in Params.Flags) or CompareSrcIdentifiers(NameAtom.StartPos,Params.Identifier)) then begin // proc identifier found // the parameters will be checked by the caller {$IFDEF ShowTriedContexts} DebugLn('[TFindDeclarationTool.FindIdentifierInProcContext] Proc-Identifier found="',GetIdentifier(@Src[NameAtom.StartPos]),'"'); {$ENDIF} Params.SetResult(Self,ProcContextNode,NameAtom.StartPos); Result:=ifrSuccess; end else begin // proceed the search normally ... end; end; end; function TFindDeclarationTool.FindIdentifierInClassOfMethod( ProcContextNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean; { this function is internally used by FindIdentifierInContext } var ClassNameAtom: TAtomPosition; OldInput: TFindDeclarationInput; ClassContext: TFindContext; IdentFoundResult: TIdentifierFoundResult; begin {$IFDEF CheckNodeTool}CheckNodeTool(ProcContextNode);{$ENDIF} Result:=false; // if proc is a method, search in class // -> find class name MoveCursorToNodeStart(ProcContextNode); ReadNextAtom; // read keyword if UpAtomIs('CLASS') then ReadNextAtom; ReadNextAtom; // read classname ClassNameAtom:=CurPos; ReadNextAtom; if AtomIsChar('.') then begin // proc is a method if CompareSrcIdentifiers(ClassNameAtom.StartPos,Params.Identifier) then begin // the class itself is searched // -> proceed the search normally ... end else begin // search the identifier in the class first // 1. search the class in the same unit Params.Save(OldInput); Params.Flags:=[fdfIgnoreCurContextNode,fdfSearchInParentNodes] +(fdfGlobals*Params.Flags) +[fdfExceptionOnNotFound,fdfIgnoreUsedUnits,fdfFindChilds] -[fdfTopLvlResolving]; Params.ContextNode:=ProcContextNode; Params.SetIdentifier(Self,@Src[ClassNameAtom.StartPos],nil); {$IFDEF ShowTriedContexts} DebugLn('[TFindDeclarationTool.FindIdentifierInClassOfMethod] Proc="',copy(src,ProcContextNode.StartPos,30),'" searching class of method class="',ExtractIdentifier(ClassNameAtom.StartPos),'"'); {$ENDIF} FindIdentifierInContext(Params); ClassContext:=Params.NewCodeTool.FindBaseTypeOfNode(Params,Params.NewNode); if (ClassContext.Node=nil) or (not (ClassContext.Node.Desc in AllClasses)) then begin MoveCursorToCleanPos(ClassNameAtom.StartPos); RaiseException(ctsClassIdentifierExpected); end; // class context found // 2. -> search identifier in class Params.Load(OldInput,false); Params.Flags:=[fdfSearchInAncestors] +(fdfGlobalsSameIdent*Params.Flags) -[fdfExceptionOnNotFound]; Params.ContextNode:=ClassContext.Node; {$IFDEF ShowTriedContexts} DebugLn('[TFindDeclarationTool.FindIdentifierInClassOfMethod] searching identifier in class of method Identifier=',GetIdentifier(Params.Identifier)); {$ENDIF} Result:=ClassContext.Tool.FindIdentifierInContext(Params); Params.Load(OldInput,true); if Result and Params.IsFinal then exit; end; end else begin // proc is not a method if (fdfCollect in Params.Flags) or CompareSrcIdentifiers(ClassNameAtom.StartPos,Params.Identifier) then begin // proc identifier found {$IFDEF ShowTriedContexts} DebugLn('[TFindDeclarationTool.FindIdentifierInClassOfMethod] Proc Identifier found="',GetIdentifier(Params.Identifier),'"'); {$ENDIF} Params.SetResult(Self,ProcContextNode,ClassNameAtom.StartPos); IdentFoundResult:=Params.NewCodeTool.DoOnIdentifierFound(Params, Params.NewNode); Result:=IdentFoundResult=ifrSuccess; exit; end else begin // proceed the search normally ... end; end; end; function TFindDeclarationTool.FindClassOfMethod(ProcNode: TCodeTreeNode; Params: TFindDeclarationParams; FindClassContext: boolean): boolean; var ClassNameAtom: TAtomPosition; OldInput: TFindDeclarationInput; ClassContext: TFindContext; CurClassNode: TCodeTreeNode; begin {$IFDEF CheckNodeTool}CheckNodeTool(ProcNode);{$ENDIF} {$IFDEF ShowTriedContexts} DebugLn('[TFindDeclarationTool.FindClassOfMethod] A '); {$ENDIF} Result:=false; if ProcNode.Desc=ctnProcedureHead then ProcNode:=ProcNode.Parent; if ProcNode.Parent.Desc in AllClassSections then begin CurClassNode:=ProcNode.Parent.Parent; if FindClassContext then begin // return the class node Params.SetResult(Self,CurClassNode); end else begin // return the type identifier node Params.SetResult(Self,CurClassNode.Parent); end; Result:=true; exit; end; MoveCursorToNodeStart(ProcNode); ReadNextAtom; // read keyword if UpAtomIs('CLASS') then ReadNextAtom; ReadNextAtom; // read classname ClassNameAtom:=CurPos; ReadNextAtom; if AtomIsChar('.') then begin // proc is a method // -> search the class Params.Save(OldInput); Params.Flags:=[fdfIgnoreCurContextNode,fdfSearchInParentNodes, fdfExceptionOnNotFound,fdfIgnoreUsedUnits] +(fdfGlobals*Params.Flags) -[fdfTopLvlResolving]; Params.ContextNode:=ProcNode; Params.SetIdentifier(Self,@Src[ClassNameAtom.StartPos],nil); {$IFDEF ShowTriedContexts} DebugLn('[TFindDeclarationTool.FindClassOfMethod] searching class of method class="',ExtractIdentifier(ClassNameAtom.StartPos),'"'); {$ENDIF} FindIdentifierInContext(Params); if FindClassContext then begin // parse class and return class node Params.Flags:=Params.Flags+[fdfFindChilds]; ClassContext:=FindBaseTypeOfNode(Params,Params.NewNode); if (ClassContext.Node=nil) or (not (ClassContext.Node.Desc in AllClasses)) then begin MoveCursorToCleanPos(ClassNameAtom.StartPos); RaiseException(ctsClassIdentifierExpected); end; // class of method found Params.SetResult(ClassContext); // parse class and return class node // ToDo: do no JIT parsing for PPU, PPW, DCU files ClassContext.Tool.BuildSubTreeForClass(ClassContext.Node); end; Result:=true; Params.Load(OldInput,true); end else begin // proc is not a method end; end; function TFindDeclarationTool.FindAncestorOfClass(ClassNode: TCodeTreeNode; Params: TFindDeclarationParams; FindClassContext: boolean): boolean; var OldInput: TFindDeclarationInput; AncestorNode, ClassIdentNode: TCodeTreeNode; SearchBaseClass: boolean; AncestorContext: TFindContext; InheritanceNode: TCodeTreeNode; begin {$IFDEF CheckNodeTool}CheckNodeTool(ClassNode);{$ENDIF} if (ClassNode=nil) or (not (ClassNode.Desc in AllClasses)) then RaiseException('[TFindDeclarationTool.FindAncestorOfClass] ' +' invalid classnode'); Result:=false; // ToDo: ppu, ppw, dcu // search the ancestor name BuildSubTreeForClass(ClassNode); InheritanceNode:=FindInheritanceNode(ClassNode); if (InheritanceNode<>nil) and (InheritanceNode.FirstChild<>nil) then begin Result:=FindAncestorOfClassInheritance(InheritanceNode.FirstChild, Params,FindClassContext); exit; end; // no ancestor class specified ClassIdentNode:=ClassNode.Parent; // check class name if (ClassIdentNode=nil) or (not (ClassIdentNode.Desc in [ctnTypeDefinition,ctnGenericType])) then begin MoveCursorToNodeStart(ClassNode); RaiseException('class without name'); end; if ClassNode.Desc=ctnClass then begin // if this class is not TObject, TObject is class ancestor SearchBaseClass:=not CompareSrcIdentifiers(ClassIdentNode.StartPos,'TObject'); end else if ClassNode.Desc in AllClassInterfaces then begin // Delphi has as default interface IInterface // FPC has as default interface IUnknown and an alias IInterface = IUnknown SearchBaseClass:= (not CompareSrcIdentifiers(ClassIdentNode.StartPos,'IInterface')) and (not CompareSrcIdentifiers(ClassIdentNode.StartPos,'IUnknown')); end else exit; if not SearchBaseClass then exit; {$IFDEF ShowTriedContexts} DebugLn('[TFindDeclarationTool.FindAncestorOfClass] ', ' search default ancestor class'); {$ENDIF} // search ancestor Params.Save(OldInput); Params.Flags:=[fdfSearchInParentNodes,fdfIgnoreCurContextNode, fdfExceptionOnNotFound] +(fdfGlobals*Params.Flags) -[fdfTopLvlResolving]; if ClassNode.Desc=ctnClass then Params.SetIdentifier(Self,'TObject',nil) else if ClassNode.Desc=ctnClassInterface then Params.SetIdentifier(Self,'IInterface',nil) else exit; Params.ContextNode:=ClassNode; if not FindIdentifierInContext(Params) then begin MoveCursorToNodeStart(ClassNode); if ClassNode.Desc=ctnClass then RaiseException(ctsDefaultClassAncestorTObjectNotFound) else RaiseException(ctsDefaultInterfaceAncestorIInterfaceNotFound); exit; end; // check result if not (Params.NewNode.Desc in [ctnTypeDefinition,ctnGenericType]) then begin MoveCursorToNodeStart(ClassNode); if ClassNode.Desc=ctnClass then RaiseException(ctsDefaultClassAncestorTObjectNotFound) else RaiseException(ctsDefaultInterfaceAncestorIInterfaceNotFound); end; // search ancestor class context if FindClassContext then begin AncestorNode:=Params.NewNode; Params.Flags:=Params.Flags+[fdfFindChilds]; AncestorContext:=Params.NewCodeTool.FindBaseTypeOfNode(Params, AncestorNode); Params.SetResult(AncestorContext); // check result if not (Params.NewNode.Desc in [ctnClass,ctnClassInterface]) then begin MoveCursorToNodeStart(ClassNode); if ClassNode.Desc=ctnClass then RaiseException(ctsDefaultClassAncestorTObjectNotFound) else RaiseException(ctsDefaultInterfaceAncestorIInterfaceNotFound); end; end; Result:=true; Params.Load(OldInput,true); end; function TFindDeclarationTool.FindAncestorOfClassInheritance( IdentifierNode: TCodeTreeNode; Params: TFindDeclarationParams; FindClassContext: boolean): boolean; var OldInput: TFindDeclarationInput; AncestorNode, ClassNode, ClassIdentNode: TCodeTreeNode; AncestorContext: TFindContext; AncestorStartPos: LongInt; begin {$IFDEF CheckNodeTool}CheckNodeTool(IdentifierNode);{$ENDIF} if (IdentifierNode=nil) or (not (IdentifierNode.Desc in [ctnIdentifier,ctnSpecialize])) or (IdentifierNode.Parent=nil) or (IdentifierNode.Parent.Desc<>ctnClassInheritance) then RaiseException('[TFindDeclarationTool.FindAncestorOfClass] ' +' not an inheritance node'); Result:=false; ClassNode:=IdentifierNode.Parent.Parent; ClassIdentNode:=ClassNode.Parent; if IdentifierNode.Desc=ctnSpecialize then begin if (IdentifierNode.FirstChild=nil) then begin MoveCursorToCleanPos(IdentifierNode.StartPos); ReadNextAtom; ReadNextAtom; RaiseStringExpectedButAtomFound('class type'); end; MoveCursorToCleanPos(IdentifierNode.FirstChild.StartPos); end else MoveCursorToCleanPos(IdentifierNode.StartPos); AncestorStartPos:=CurPos.StartPos; ReadNextAtom; AtomIsIdentifier(true); ReadNextAtom; if CurPos.Flag=cafPoint then begin ReadNextAtom; AtomIsIdentifier(true); AncestorStartPos:=CurPos.StartPos; end; if (ClassIdentNode<>nil) and (ClassIdentNode.Desc=ctnTypeDefinition) and (CompareIdentifiers(@Src[AncestorStartPos], @Src[ClassIdentNode.StartPos])=0) then begin MoveCursorToCleanPos(AncestorStartPos); RaiseException('ancestor has same name as class'); end; {$IFDEF ShowTriedContexts} DebugLn('[TFindDeclarationTool.FindAncestorOfClass] ', ' search ancestor class = ',GetIdentifier(@Src[AncestorStartPos])); {$ENDIF} // search ancestor Params.Save(OldInput); Params.Flags:=[fdfSearchInParentNodes,fdfIgnoreCurContextNode, fdfExceptionOnNotFound] +(fdfGlobals*Params.Flags) -[fdfTopLvlResolving]; Params.SetIdentifier(Self,@Src[AncestorStartPos],nil); Params.ContextNode:=ClassIdentNode; if not FindIdentifierInContext(Params) then exit; // check result if not (Params.NewNode.Desc in [ctnTypeDefinition,ctnGenericType]) then begin MoveCursorToCleanPos(AncestorStartPos); ReadNextAtom; RaiseExceptionFmt(ctsStrExpectedButAtomFound,['type',GetAtom]); end; // search ancestor class context if FindClassContext then begin AncestorNode:=Params.NewNode; Params.Flags:=Params.Flags+[fdfFindChilds]; AncestorContext:=Params.NewCodeTool.FindBaseTypeOfNode(Params, AncestorNode); Params.SetResult(AncestorContext); // check result if not (Params.NewNode.Desc in AllClasses) then begin MoveCursorToCleanPos(AncestorStartPos); ReadNextAtom; RaiseExceptionFmt(ctsStrExpectedButAtomFound,['class',GetAtom]); end; end; Result:=true; Params.Load(OldInput,true); end; function TFindDeclarationTool.FindAncestorsOfClass(ClassNode: TCodeTreeNode; var ListOfPFindContext: TFPList; Params: TFindDeclarationParams; FindClassContext: boolean; ExceptionOnNotFound: boolean): boolean; var Node: TCodeTreeNode; Context: TFindContext; InheritanceNode: TCodeTreeNode; begin Result:=false; InheritanceNode:=FindInheritanceNode(ClassNode); if (InheritanceNode=nil) then exit(true); Node:=InheritanceNode.FirstChild; if Node=nil then begin try if not FindAncestorOfClass(ClassNode,Params,FindClassContext) then begin exit(true); // this is TObject or IInterface, IUnknown end else begin Context:=CreateFindContext(Params); end; AddFindContext(ListOfPFindContext,Context); Result:=Context.Node<>nil; except if ExceptionOnNotFound then raise; end; end else begin while Node<>nil do begin try if FindAncestorOfClassInheritance(Node,Params,FindClassContext) then begin Context:=CreateFindContext(Params); AddFindContext(ListOfPFindContext,Context); end; except if ExceptionOnNotFound then raise; end; Node:=Node.NextBrother; end; end; Result:=true; end; function TFindDeclarationTool.FindForwardIdentifier( Params: TFindDeclarationParams; var IsForward: boolean): boolean; { first search the identifier in the normal way via FindIdentifierInContext then search the other direction } var OldInput: TFindDeclarationInput; begin Params.Save(OldInput); Exclude(Params.Flags,fdfExceptionOnNotFound); Result:=FindIdentifierInContext(Params); if not Result then begin Params.Load(OldInput,false); Params.Flags:=Params.Flags+[fdfSearchForward,fdfIgnoreCurContextNode]; Result:=FindIdentifierInContext(Params); IsForward:=true; end else begin IsForward:=false; end; Params.Load(OldInput,true); end; function TFindDeclarationTool.FindNonForwardClass(Params: TFindDeclarationParams ): boolean; var Node: TCodeTreeNode; begin Result:=false; Node:=Params.NewNode; if Node.Desc=ctnGenericType then begin Node:=Node.FirstChild; if Node=nil then exit; end else if Node.Desc<>ctnTypeDefinition then exit; Node:=Node.FirstChild; if (Node=nil) or (not (Node.Desc in AllClasses)) or ((ctnsForwardDeclaration and Node.SubDesc)=0) then exit; Node:=Params.NewNode; repeat //DebugLn(['TFindDeclarationTool.FindNonForwardClass Node=',dbgstr(copy(Src,Node.StartPos,20))]); if Node.NextBrother<>nil then Node:=Node.NextBrother else if (Node.Parent=nil) or (not (Node.Parent.Desc in AllDefinitionSections)) then break else begin Node:=Node.Parent.NextBrother; while (Node<>nil) and ((Node.FirstChild=nil) or (not (Node.Desc in AllDefinitionSections))) do Node:=Node.NextBrother; if Node=nil then break; Node:=Node.FirstChild; end; if CompareSrcIdentifiers(Node.StartPos,Params.Identifier) then begin Params.SetResult(Self,Node,Node.StartPos); Result:=true; exit; end; until false; end; function TFindDeclarationTool.FindIdentifierInWithVarContext( WithVarNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean; { this function is internally used by FindIdentifierInContext } var WithVarExpr: TExpressionType; OldInput: TFindDeclarationInput; begin {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.FindIdentifierInWithVarContext] Ident=', '"',GetIdentifier(Params.Identifier),'"', ' WithStart=',StringToPascalConst(copy(Src,WithVarNode.StartPos,15)) ); {$ENDIF} {$IFDEF CheckNodeTool}CheckNodeTool(WithVarNode);{$ENDIF} Result:=false; // find the base type of the with variable // move cursor to end of with-variable Params.Save(OldInput); Params.ContextNode:=WithVarNode; Params.Flags:=Params.Flags*fdfGlobals +[fdfExceptionOnNotFound,fdfFunctionResult,fdfFindChilds]; WithVarExpr:=FindExpressionTypeOfTerm(WithVarNode.StartPos,-1,Params,true); if (WithVarExpr.Desc<>xtContext) or (WithVarExpr.Context.Node=nil) or (WithVarExpr.Context.Node=OldInput.ContextNode) or (not (WithVarExpr.Context.Node.Desc in (AllClasses+[ctnRecordType,ctnEnumerationType]))) then begin MoveCursorToCleanPos(WithVarNode.StartPos); RaiseException(ctsExprTypeMustBeClassOrRecord); end; // search identifier in 'with' context // Note: do not search in parent nodes (e.g. with ListBox1 do Items) Params.Load(OldInput,false); Params.Flags:=Params.Flags-[fdfExceptionOnNotFound,fdfSearchInParentNodes]; Params.ContextNode:=WithVarExpr.Context.Node; Result:=WithVarExpr.Context.Tool.FindIdentifierInContext(Params); Params.Load(OldInput,true); end; function TFindDeclarationTool.FindIdentifierInAncestors( ClassNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean; { this function is internally used by FindIdentifierInContext and FindBaseTypeOfNode } var OldInput: TFindDeclarationInput; begin Result:=false; if not (fdfSearchInAncestors in Params.Flags) then exit; Result:=FindAncestorOfClass(ClassNode,Params,true); if not Result then exit; Params.Save(OldInput); Params.ContextNode:=Params.NewNode; Params.Flags:=Params.Flags-[fdfIgnoreCurContextNode,fdfSearchInParentNodes]; Result:=Params.NewCodeTool.FindIdentifierInContext(Params); Params.Load(OldInput,true); end; {$IFDEF DebugPrefix} procedure TFindDeclarationTool.DecPrefix; begin DebugPrefix:=copy(DebugPrefix,1,length(DebugPrefix)-2); end; procedure TFindDeclarationTool.IncPrefix; begin DebugPrefix:=DebugPrefix+' '; end; {$ENDIF} function TFindDeclarationTool.FindExpressionResultType( Params: TFindDeclarationParams; StartPos, EndPos: integer): TExpressionType; { - operators - mixing ansistring and shortstring gives ansistring - Pointer +,- Pointer gives Pointer - Sets: [enum1] gives set of enumeration type set *,-,+ set gives set of same type set <>,=,<,> set gives boolean - precedence rules table: 1. brackets 2. not @ sign 3. * / div mod and shl shr as 4. + - or xor 5. < <> > <= >= in is - nil is compatible to pointers and classes - operator overloading? - internal types. e.g. string[], ansistring[], shortstring[], pchar[] to char - the type of a subrange is the type of the first constant/enum/number/char - predefined types: ordinal: int64, cardinal, QWord, boolean, bytebool, wordbool, qwordbool, longbool, char real: real, single, double, extended, comp, currency - predefined functions: function pred(ordinal type): ordinal constant of same type; function succ(ordinal type): ordinal constant of same type; function ord(ordinal type): ordinal type; val? function low(array): type of leftmost index type in the array; function high(array): type of leftmost index type in the array; procedure dec(ordinal var); procedure dec(ordinal var; ordinal type); procedure dec(pointer var); procedure dec(pointer var; ordinal type); procedure inc(ordinal var); procedure inc(ordinal var; ordinal type); procedure inc(pointer var); procedure inc(pointer var; ordinal type); procedure write(...); procedure writeln(...); function SizeOf(type): ordinal constant; typeinfo? uniquestring? procedure include(set type,enum identifier); procedure exclude(set type,enum identifier); function objcselector(string): sel; } type TOperandAndOperator = record Operand: TExpressionType; theOperator: TAtomPosition; OperatorLvl: integer; end; TExprStack = array[0..4] of TOperandAndOperator; var CurExprType: TExpressionType; ExprStack: TExprStack; StackPtr: integer; procedure ExecuteStack(Complete: boolean); { Executes the oerand+operator stack Examples: Position Operand Operator 0 AWord * 1 AByte + Because * has higher predence than + the stack is executed: AWord*AByte gives an integer. New stack Position Operand Operator 0 Integer + } var NewOperand: TExpressionType; LastPos: TAtomPosition; begin if StackPtr<=0 then begin // only one element -> nothing to do exit; end; LastPos:=CurPos; {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.FindExpressionResultType.ExecuteStack] ', ' StackPtr=',dbgs(StackPtr), ' Lvl=',dbgs(ExprStack[StackPtr].OperatorLvl), ' Complete=',dbgs(Complete)); {$ENDIF} while (StackPtr>0) and (Complete or (ExprStack[StackPtr-1].OperatorLvl>=ExprStack[StackPtr].OperatorLvl)) do begin // next operand has a lower or equal priority/precedence // -> calculate last two operands NewOperand:=CalculateBinaryOperator(ExprStack[StackPtr-1].Operand, ExprStack[StackPtr].Operand,ExprStack[StackPtr-1].theOperator, Params); // put result on stack ExprStack[StackPtr-1]:=ExprStack[StackPtr]; dec(StackPtr); ExprStack[StackPtr].Operand:=NewOperand; end; MoveCursorToAtomPos(LastPos); end; procedure RaiseBinaryOperatorNotFound; begin RaiseExceptionFmt(ctsStrExpectedButAtomFound,[ctsBinaryOperator,GetAtom]); end; procedure RaiseInternalError; begin RaiseException('[TFindDeclarationTool.FindExpressionResultType]' +' internal error: unknown precedence lvl for operator '+GetAtom); end; procedure RaiseInternalErrorStack; begin RaiseException('[TFindDeclarationTool.FindExpressionResultType]' +' internal error: stackptr too big '); end; var OldFlags: TFindDeclarationFlags; begin {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.FindExpressionResultType] Start', ' Pos=',dbgs(StartPos),'-',dbgs(EndPos), '="',copy(Src,StartPos,EndPos-StartPos),'" Context=',Params.ContextNode.DescAsString); {$ENDIF} Result:=CleanExpressionType; OldFlags:=Params.Flags; Exclude(Params.Flags,fdfFindVariable); // read the expression from left to right and calculate the type StackPtr:=-1; MoveCursorToCleanPos(StartPos); repeat // read operand CurExprType:=ReadOperandTypeAtCursor(Params,EndPos); {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.FindExpressionResultType] Operand: ', ExprTypeToString(CurExprType)); {$ENDIF} // put operand on stack inc(StackPtr); if StackPtr>High(ExprStack) then RaiseInternalErrorStack; ExprStack[StackPtr].Operand:=CurExprType; ExprStack[StackPtr].theOperator.StartPos:=-1; ExprStack[StackPtr].OperatorLvl:=5; // read operator ReadNextAtom; {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.FindExpressionResultType] Operator: ', GetAtom,' CurPos.EndPos=',dbgs(CurPos.EndPos),' EndPos=',dbgs(EndPos)); {$ENDIF} // check if expression is completely parsed if (CurPos.EndPos>EndPos) or (CurExprType.Desc=xtNone) then begin // -> execute complete stack ExecuteStack(true); Result:=ExprStack[StackPtr].Operand; Params.Flags:=OldFlags; exit; end; if not WordIsBinaryOperator.DoItCaseInsensitive(Src,CurPos.StartPos, CurPos.EndPos-CurPos.StartPos) then RaiseBinaryOperatorNotFound; // put operator on stack ExprStack[StackPtr].theOperator:=CurPos; // find operator precendence level if WordIsLvl1Operator.DoItCaseInsensitive(Src,CurPos.StartPos, CurPos.EndPos-CurPos.StartPos) then ExprStack[StackPtr].OperatorLvl:=1 else if WordIsLvl2Operator.DoItCaseInsensitive(Src,CurPos.StartPos, CurPos.EndPos-CurPos.StartPos) then ExprStack[StackPtr].OperatorLvl:=2 else if WordIsLvl3Operator.DoItCaseInsensitive(Src,CurPos.StartPos, CurPos.EndPos-CurPos.StartPos) then ExprStack[StackPtr].OperatorLvl:=3 else if WordIsLvl4Operator.DoItCaseInsensitive(Src,CurPos.StartPos, CurPos.EndPos-CurPos.StartPos) then ExprStack[StackPtr].OperatorLvl:=4 else RaiseInternalError; // execute stack if possible ExecuteStack(false); // move cursor to next atom (= next operand start) ReadNextAtom; until false; end; function TFindDeclarationTool.FindIdentifierInUsesSection( UsesNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean; { this function is internally used by FindIdentifierInContext search backwards through the uses section compare first the all unit names, then load the units and search there } var InAtom, UnitNameAtom: TAtomPosition; NewCodeTool: TFindDeclarationTool; OldFlags: TFindDeclarationFlags; Node: TCodeTreeNode; begin {$IFDEF CheckNodeTool}CheckNodeTool(UsesNode);{$ENDIF} {$IFDEF ShowTriedParentContexts} DebugLn(['TFindDeclarationTool.FindIdentifierInUsesSection ',MainFilename,' fdfIgnoreUsedUnits=',fdfIgnoreUsedUnits in Params.Flags]); {$ENDIF} Result:=false; if (Params.IdentifierTool=Self) then begin Node:=UsesNode.LastChild; while Node<>nil do begin if CompareSrcIdentifiers(Node.StartPos,Params.Identifier) then begin // the searched identifier was a uses AUnitName, point to the identifier in // the uses section Result:=true; Params.SetResult(Self,Node,Node.StartPos); exit; end; Node:=Node.PriorBrother; end; end; if not (fdfIgnoreUsedUnits in Params.Flags) then begin // search in units Node:=UsesNode.LastChild; while Node<>nil do begin MoveCursorToCleanPos(Node.StartPos); ReadNextAtom; UnitNameAtom:=CurPos; ReadNextAtom; if UpAtomIs('IN') then begin ReadNextAtom; InAtom:=CurPos; end else InAtom.StartPos:=0; NewCodeTool:=OpenCodeToolForUnit(UnitNameAtom,InAtom,true); // search the identifier in the interface of the used unit OldFlags:=Params.Flags; Params.Flags:=[fdfIgnoreUsedUnits]+(fdfGlobalsSameIdent*Params.Flags) -[fdfExceptionOnNotFound]; Result:=NewCodeTool.FindIdentifierInInterface(Self,Params); Params.Flags:=OldFlags; {$IFDEF ShowTriedParentContexts} DebugLn(['TFindDeclarationTool.FindIdentifierInUsesSection ',GetAtom(UnitNameAtom),' Result=',Result,' IsFinal=',Params.IsFinal]); {$ENDIF} if Result and Params.IsFinal then exit; Node:=Node.PriorBrother; end; end; end; function TFindDeclarationTool.FindCodeToolForUsedUnit(UnitNameAtom, UnitInFileAtom: TAtomPosition; ExceptionOnNotFound: boolean): TFindDeclarationTool; var AnUnitName, AnUnitInFilename: string; begin Result:=nil; if (UnitNameAtom.StartPos<1) or (UnitNameAtom.EndPos<=UnitNameAtom.StartPos) or (UnitNameAtom.EndPos>SrcLen+1) then RaiseException('[TFindDeclarationTool.FindCodeToolForUsedUnit] ' +'internal error: invalid UnitNameAtom'); AnUnitName:=copy(Src,UnitNameAtom.StartPos, UnitNameAtom.EndPos-UnitNameAtom.StartPos); if UnitInFileAtom.StartPos>=1 then begin if (UnitInFileAtom.StartPos<1) or (UnitInFileAtom.EndPos<=UnitInFileAtom.StartPos) or (UnitInFileAtom.EndPos>SrcLen+1) then RaiseException('[TFindDeclarationTool.FindCodeToolForUsedUnit] ' +'internal error: invalid UnitInFileAtom'); AnUnitInFilename:=copy(Src,UnitInFileAtom.StartPos+1, UnitInFileAtom.EndPos-UnitInFileAtom.StartPos-2); end else AnUnitInFilename:=''; Result:=FindCodeToolForUsedUnit(AnUnitName,AnUnitInFilename,ExceptionOnNotFound); end; function TFindDeclarationTool.FindCodeToolForUsedUnit(const AnUnitName, AnUnitInFilename: string; ExceptionOnNotFound: boolean): TFindDeclarationTool; var NewCode: TCodeBuffer; begin Result:=nil; NewCode:=FindUnitSource(AnUnitName,AnUnitInFilename,ExceptionOnNotFound); if (NewCode=nil) then begin // no source found if ExceptionOnNotFound then RaiseException('unit '+AnUnitName+' not found'); end else begin // source found -> get codetool for it {$IF defined(ShowTriedFiles) or defined(ShowTriedUnits)} DebugLn('[TFindDeclarationTool.FindCodeToolForUsedUnit] ', ' This source is=',TCodeBuffer(Scanner.MainCode).Filename, ' NewCode=',NewCode.Filename); {$ENDIF} if Assigned(FOnGetCodeToolForBuffer) then Result:=FOnGetCodeToolForBuffer(Self,NewCode,false) else if NewCode=TCodeBuffer(Scanner.MainCode) then Result:=Self; end; end; function TFindDeclarationTool.FindUnitSourceWithUnitIdentifier( UsesNode: TCodeTreeNode; const AnUnitIdentifier: string; ExceptionOnNotFound: boolean): TCodeBuffer; procedure RaiseUnitNotFound; begin RaiseExceptionInstance( ECodeToolUnitNotFound.Create(Self,Format(ctsUnitNotFound,[AnUnitIdentifier]), AnUnitIdentifier)); end; var UnitNamePos: TAtomPosition; UnitInFilePos: TAtomPosition; UnitInFilename: String; begin Result:=nil; {$IFDEF ShowTriedContexts} DebugLn('TFindDeclarationTool.FindUnitSourceWithUnitIdentifier A'); {$ENDIF} {$IFDEF CheckNodeTool}CheckNodeTool(UsesNode);{$ENDIF} // reparse uses section MoveCursorToNodeStart(UsesNode); if (UsesNode.Desc=ctnUsesSection) then begin ReadNextAtom; if not UpAtomIs('USES') then RaiseUsesExpected; end; repeat ReadNextAtom; // read name if AtomIsChar(';') then break; AtomIsIdentifier(true); UnitNamePos:=CurPos; ReadNextAtom; if UpAtomIs('IN') then begin ReadNextAtom; if not AtomIsStringConstant then RaiseStrConstExpected; UnitInFilePos:=CurPos; ReadNextAtom; end else UnitInFilePos.StartPos:=-1; if CompareIdentifierPtrs(@Src[UnitNamePos.StartPos], PChar(Pointer(AnUnitIdentifier)))=0 then begin // cursor is on a AUnitName -> try to locate it if UnitInFilePos.StartPos>=1 then begin UnitInFilename:=copy(Src,UnitInFilePos.StartPos+1, UnitInFilePos.EndPos-UnitInFilePos.StartPos-2) end else UnitInFilename:=''; Result:=FindUnitSource(AnUnitIdentifier,UnitInFilename,true); if (Result=nil) and ExceptionOnNotFound then RaiseUnitNotFound; exit; end; if AtomIsChar(';') then break; if not AtomIsChar(',') then RaiseExceptionFmt(ctsStrExpectedButAtomFound,[';',GetAtom]) until (CurPos.StartPos>SrcLen); {$IFDEF ShowTriedContexts} DebugLn('TFindDeclarationTool.FindUnitSourceWithUnitIdentifier END identifier not found in uses section'); {$ENDIF} if ExceptionOnNotFound then RaiseUnitNotFound; end; function TFindDeclarationTool.FindCodeToolForUnitIdentifier( UsesNode: TCodeTreeNode; const AnUnitIdentifier: string; ExceptionOnNotFound: boolean): TFindDeclarationTool; var NewCode: TCodeBuffer; begin Result:=nil; NewCode:=FindUnitSourceWithUnitIdentifier(UsesNode,AnUnitIdentifier, ExceptionOnNotFound); if NewCode=nil then exit; if Assigned(FOnGetCodeToolForBuffer) then Result:=FOnGetCodeToolForBuffer(Self,NewCode,false) else if NewCode=TCodeBuffer(Scanner.MainCode) then Result:=Self; if (Result=nil) and ExceptionOnNotFound then RaiseExceptionInstance( ECodeToolUnitNotFound.Create(Self,Format(ctsUnitNotFound,[AnUnitIdentifier]), AnUnitIdentifier)); end; function TFindDeclarationTool.FindIdentifierInInterface( AskingTool: TFindDeclarationTool; Params: TFindDeclarationParams): boolean; function CheckEntry(Entry: PInterfaceIdentCacheEntry): TIdentifierFoundResult; begin while Entry<>nil do begin Params.SetResult(Self,Entry^.Node,Entry^.CleanPos); Result:=DoOnIdentifierFound(Params,Params.NewNode); if Result in [ifrSuccess,ifrAbortSearch] then exit; // proceed Entry:=Entry^.Overloaded; end; Result:=ifrProceedSearch; end; var CacheEntry: PInterfaceIdentCacheEntry; AVLNode: TAVLTreeNode; begin Result:=false; // build code tree {$IFDEF ShowTriedContexts} DebugLn({$IFDEF DebugPrefix}DebugPrefix,{$ENDIF} 'TFindDeclarationTool.FindIdentifierInInterface', ' Ident="',GetIdentifier(Params.Identifier),'"', ' IgnoreUsedUnits=',dbgs(fdfIgnoreUsedUnits in Params.Flags), ' Self=',TCodeBuffer(Scanner.MainCode).Filename ); {$ENDIF} // ToDo: build codetree for ppu, ppw, dcu files // build tree for pascal source if not BuildInterfaceIdentifierCache(true) then exit(false); if (AskingTool<>Self) and (AskingTool<>nil) then AskingTool.AddToolDependency(Self); // search identifier in cache if fdfCollect in Params.Flags then begin AVLNode:=FInterfaceIdentifierCache.Items.FindLowest; while AVLNode<>nil do begin CacheEntry:=PInterfaceIdentCacheEntry(AVLNode.Data); //DebugLn(['TFindDeclarationTool.FindIdentifierInInterface ',CacheEntry^.Identifier]); case CheckEntry(CacheEntry) of ifrSuccess: exit(true); ifrAbortSearch: exit(false); end; AVLNode:=FInterfaceIdentifierCache.Items.FindSuccessor(AVLNode); end; end else begin CacheEntry:=FInterfaceIdentifierCache.FindIdentifier(Params.Identifier); if CacheEntry=nil then exit(false); case CheckEntry(CacheEntry) of ifrSuccess: exit(true); ifrAbortSearch: exit(false); end; end; // proceed search Result:=false; end; function TFindDeclarationTool.BuildInterfaceIdentifierCache( ExceptionOnNotUnit: boolean): boolean; procedure ScanForEnums(ParentNode: TCodeTreeNode); var Node: TCodeTreeNode; begin Node:=ParentNode.FirstChild; while Node<>nil do begin if Node.Desc=ctnEnumIdentifier then FInterfaceIdentifierCache.Add(@Src[Node.StartPos],Node,Node.StartPos); if Node.FirstChild<>nil then Node:=Node.FirstChild else begin while Node.NextBrother=nil do begin Node:=Node.Parent; if Node=ParentNode then exit; end; Node:=Node.NextBrother; end; end; end; procedure ScanChilds(ParentNode: TCodeTreeNode); forward; procedure ScanNode(Node: TCodeTreeNode); begin case Node.Desc of ctnTypeSection,ctnConstSection,ctnVarSection,ctnResStrSection: ScanChilds(Node); ctnVarDefinition,ctnConstDefinition,ctnTypeDefinition: begin FInterfaceIdentifierCache.Add(@Src[Node.StartPos],Node,Node.StartPos); ScanForEnums(Node); end; ctnGenericType: if Node.FirstChild<>nil then begin FInterfaceIdentifierCache.Add(@Src[Node.FirstChild.StartPos],Node,Node.StartPos); ScanForEnums(Node); end; ctnProperty: begin MoveCursorToPropName(Node); FInterfaceIdentifierCache.Add(@Src[CurPos.StartPos],Node,Node.StartPos); end; ctnProcedure: if (Node.FirstChild<>nil) and (not NodeIsOperator(Node)) then FInterfaceIdentifierCache.Add(@Src[Node.FirstChild.StartPos],Node, Node.FirstChild.StartPos); end; end; procedure ScanChilds(ParentNode: TCodeTreeNode); var Node: TCodeTreeNode; begin Node:=ParentNode.FirstChild; while Node<>nil do begin ScanNode(Node); Node:=Node.NextBrother; end; end; var InterfaceNode: TCodeTreeNode; Node: TCodeTreeNode; begin // build tree for pascal source //debugln(['TFindDeclarationTool.BuildInterfaceIdentifierCache BEFORE ',MainFilename]); BuildTree(true); //debugln(['TFindDeclarationTool.BuildInterfaceIdentifierCache AFTER ',MainFilename]); // search interface section InterfaceNode:=FindInterfaceNode; if InterfaceNode=nil then begin // check source type if ExceptionOnNotUnit then begin MoveCursorToNodeStart(Tree.Root); ReadNextAtom; // read keyword for source type, e.g. 'unit' if not UpAtomIs('UNIT') then RaiseException(ctsSourceIsNotUnit); RaiseException(ctsInterfaceSectionNotFound); end; end; // create tree if (FInterfaceIdentifierCache<>nil) and FInterfaceIdentifierCache.Complete then exit(true); if FInterfaceIdentifierCache=nil then FInterfaceIdentifierCache:=TInterfaceIdentifierCache.Create(Self) else FInterfaceIdentifierCache.Clear; FInterfaceIdentifierCache.Complete:=true; // add unit node MoveCursorToNodeStart(Tree.Root); ReadNextAtom; // keyword unit ReadNextAtom; FInterfaceIdentifierCache.Add(@Src[CurPos.StartPos],Tree.Root,CurPos.StartPos); // create nodes if InterfaceNode<>nil then // scan interface ScanChilds(InterfaceNode) else begin // scan program Node:=Tree.Root; while Node<>nil do begin ScanNode(Node); Node:=Node.NextBrother; end; end; //DebugLn(['TFindDeclarationTool.BuildInterfaceIdentifierCache ',MainFilename,' ',FInterfaceIdentifierCache.Items.Count,' ',GlobalIdentifierTree.Count]); Result:=true; end; function TFindDeclarationTool.CompareNodeIdentifier(Node: TCodeTreeNode; Params: TFindDeclarationParams): boolean; begin {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF} Result:=false; if Node=nil then exit; if Node.Desc in AllSourceTypes then begin MoveCursorToNodeStart(Node); ReadNextAtom; ReadNextAtom; Result:=CompareSrcIdentifiers(CurPos.StartPos,Params.Identifier); end else if (Node.Desc in AllSimpleIdentifierDefinitions) or (Node.Desc in [ctnIdentifier,ctnGenericName]) then begin Result:=CompareSrcIdentifiers(Node.StartPos,Params.Identifier); end else if Node.Desc=ctnGenericType then begin if Node.FirstChild<>nil then Result:=CompareSrcIdentifiers(Node.FirstChild.StartPos,Params.Identifier); end; end; function TFindDeclarationTool.GetInterfaceNode: TCodeTreeNode; begin Result:=Tree.Root; if Result=nil then begin CurPos.StartPos:=-1; RaiseException('[TFindDeclarationTool.GetInterfaceNode] no code tree found'); end; if not (Tree.Root.Desc in AllUsableSourceTypes) then begin CurPos.StartPos:=-1; RaiseException(ctsUsedUnitIsNotAPascalUnit); end; Result:=FindInterfaceNode; if Result=nil then begin CurPos.StartPos:=-1; RaiseException(ctsInterfaceSectionNotFound); end; end; function TFindDeclarationTool.FindIdentifierInUsedUnit( const AnUnitName: string; Params: TFindDeclarationParams): boolean; { this function is internally used by FindIdentifierInHiddenUsedUnits for hidden used units, like the system unit or the objpas unit } var NewCode: TCodeBuffer; NewCodeTool: TFindDeclarationTool; OldFlags: TFindDeclarationFlags; begin Result:=false; // open the unit and search the identifier in the interface NewCode:=FindUnitSource(AnUnitName,'',true); if (NewCode=nil) then begin // no source found CurPos.StartPos:=-1; RaiseExceptionInstance( ECodeToolUnitNotFound.Create(Self,Format(ctsUnitNotFound,[AnUnitName]),AnUnitName)); end else if NewCode=TCodeBuffer(Scanner.MainCode) then begin // Searching again in hidden unit DebugLn('WARNING: Searching again in hidden unit: "',NewCode.Filename,'"'); end else begin // source found -> get codetool for it {$IF defined(ShowTriedContexts) or defined(ShowTriedUnits)} DebugLn('[TFindDeclarationTool.FindIdentifierInUsedUnit] ', ' This source is=',TCodeBuffer(Scanner.MainCode).Filename, ' NewCode=',NewCode.Filename,' IgnoreUsedUnits=',dbgs(fdfIgnoreUsedUnits in Params.Flags)); {$ENDIF} if Assigned(FOnGetCodeToolForBuffer) then begin NewCodeTool:=FOnGetCodeToolForBuffer(Self,NewCode,false); if NewCodeTool=nil then begin CurPos.StartPos:=-1; RaiseExceptionInstance( ECodeToolUnitNotFound.Create(Self,Format(ctsUnitNotFound,[AnUnitName]), AnUnitName)); end; end else if NewCode=TCodeBuffer(Scanner.MainCode) then begin NewCodeTool:=Self; CurPos.StartPos:=-1; RaiseExceptionFmt(ctsIllegalCircleInUsedUnits,[AnUnitName]); end; // search the identifier in the interface of the used unit OldFlags:=Params.Flags; Params.Flags:=[fdfIgnoreUsedUnits]+(fdfGlobalsSameIdent*Params.Flags) -[fdfExceptionOnNotFound]; Result:=NewCodeTool.FindIdentifierInInterface(Self,Params); Params.Flags:=OldFlags; end; end; function TFindDeclarationTool.FindIdentifierInRecordCase( RecordCaseNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean; var IdentPos: LongInt; begin Result:=false; MoveCursorToNodeStart(RecordCaseNode); ReadNextAtom;// case ReadNextAtom;// identifier IdentPos:=CurPos.StartPos; ReadNextAtom; if AtomIsChar(':') and ((fdfCollect in Params.Flags) or CompareSrcIdentifiers(IdentPos,Params.Identifier)) then begin // identifier found {$IFDEF ShowTriedContexts} DebugLn('[TFindDeclarationTool.FindIdentifierInRecordCase] found="',GetIdentifier(Params.Identifier),'" Src=',GetIdentifier(@Src[IdentPos])); {$ENDIF} Params.SetResult(Self,RecordCaseNode,IdentPos); Result:=true; end else begin // proceed the search normally ... end; end; procedure TFindDeclarationTool.RaiseUsesExpected; begin RaiseExceptionFmt(ctsStrExpectedButAtomFound,['"uses"',GetAtom]); end; procedure TFindDeclarationTool.RaiseStrConstExpected; begin RaiseExceptionFmt(ctsStrExpectedButAtomFound,[ctsStringConstant,GetAtom]); end; procedure TFindDeclarationTool.BeginParsing(DeleteNodes, OnlyInterfaceNeeded: boolean); begin // scan code and init parser inherited BeginParsing(DeleteNodes,OnlyInterfaceNeeded); // now the scanner knows, which compiler mode is needed // -> setup compiler dependent tables case Scanner.PascalCompiler of pcDelphi: WordIsPredefinedIdentifier:=WordIsPredefinedDelphiIdentifier; else WordIsPredefinedIdentifier:=WordIsPredefinedFPCIdentifier; end; end; function TFindDeclarationTool.FindIdentifierInHiddenUsedUnits( Params: TFindDeclarationParams): boolean; type SystemUnitType = ( sutSystem, sutMacPas, sutObjPas, sutObjC, sutObjCBase, sutLineInfo, sutHeapTrc, sutSysThrds, sutNone); var OldInput: TFindDeclarationInput; SystemAlias: string; CurUnitType: SystemUnitType; begin Result:=false; {$IFDEF ShowTriedContexts} DebugLn('[TFindDeclarationTool.FindIdentifierInHiddenUsedUnits] ', '"',GetIdentifier(Params.Identifier),'" IgnoreUsedUnits=',dbgs(fdfIgnoreUsedUnits in Params.Flags)); {$ENDIF} if (Tree.Root<>nil) and (not (fdfIgnoreUsedUnits in Params.Flags)) then begin // check, if this is a special unit MoveCursorToNodeStart(Tree.Root); ReadNextAtom; ReadNextAtom; SystemAlias:='SYSTEM'; if (Scanner.PascalCompiler=pcDelphi) then begin SystemAlias:='System'; end else begin // FPC if Scanner.InitialValues.IsDefined('VER1_0') then begin if Scanner.InitialValues.IsDefined('LINUX') then SystemAlias:='SYSLINUX' else if Scanner.InitialValues.IsDefined('BSD') then SystemAlias:='SYSBSD' else if Scanner.InitialValues.IsDefined('WIN32') then SystemAlias:='SYSWIN32'; end; end; if UpAtomIs(SystemAlias) or UpAtomIs('SYSTEM') then CurUnitType:=sutSystem else if UpAtomIs('MACPAS') then CurUnitType:=sutMacPas else if UpAtomIs('OBJPAS') then CurUnitType:=sutObjPas else if UpAtomIs('OBJC') then CurUnitType:=sutObjC else if UpAtomIs('OBJCBASE') then CurUnitType:=sutObjCBase else if UpAtomIs('LINEINFO') then CurUnitType:=sutLineInfo else if UpAtomIs('HEAPTRC') then CurUnitType:=sutHeapTrc else if UpAtomIs('SYSTHRDS') then CurUnitType:=sutSysThrds else CurUnitType:=sutNone; // try hidden units if (CurUnitType>sutSysThrds) and Scanner.InitialValues.IsDefined(ExternalMacroStart+'UseSysThrds') then begin // try hidden used unit 'systhrds' Result:=FindIdentifierInUsedUnit('SysThrds',Params); if Result and Params.IsFinal then exit; end; if (CurUnitType>sutHeapTrc) and Scanner.InitialValues.IsDefined(ExternalMacroStart+'UseHeapTrcUnit') then begin // try hidden used unit 'heaptrc' Result:=FindIdentifierInUsedUnit('HeapTrc',Params); if Result and Params.IsFinal then exit; end; if (CurUnitType>sutLineInfo) and Scanner.InitialValues.IsDefined(ExternalMacroStart+'UseLineInfo') then begin // try hidden used unit 'lineinfo' Result:=FindIdentifierInUsedUnit('LineInfo',Params); if Result and Params.IsFinal then exit; end; if (CurUnitType>sutObjPas) and (Scanner.CompilerMode in [cmDELPHI,cmOBJFPC]) and (Scanner.PascalCompiler=pcFPC) then begin // try hidden used fpc unit 'objpas' Result:=FindIdentifierInUsedUnit('ObjPas',Params); if Result and Params.IsFinal then exit; end; if (CurUnitType>sutObjCBase) and (Scanner.CompilerModeSwitch=cmsObjectiveC1) then begin // try hidden used fpc unit 'objcbase' Result:=FindIdentifierInUsedUnit('ObjCBase',Params); if Result and Params.IsFinal then exit; end; if (CurUnitType>sutObjC) and (Scanner.CompilerModeSwitch=cmsObjectiveC1) then begin // try hidden used fpc unit 'objc' Result:=FindIdentifierInUsedUnit('ObjC',Params); if Result and Params.IsFinal then exit; end; if (CurUnitType>sutMacPas) and (Scanner.CompilerMode=cmMacPas) and (Scanner.PascalCompiler=pcFPC) then begin // try hidden used fpc unit 'macpas' Result:=FindIdentifierInUsedUnit('MacPas',Params); if Result and Params.IsFinal then exit; end; if (CurUnitType>sutSystem) then begin // try hidden used unit 'system' if not CompareSrcIdentifiers(Params.Identifier,'system') then begin Result:=FindIdentifierInUsedUnit(SystemAlias,Params); end else begin // the system unit name itself is searched -> rename searched identifier Params.Save(OldInput); Params.SetIdentifier(Self,PChar(Pointer(SystemAlias)),nil); Result:=FindIdentifierInUsedUnit(SystemAlias,Params); Params.Load(OldInput,true); end; end; if Result and Params.IsFinal then exit; end; end; function TFindDeclarationTool.FindEndOfTerm( StartPos: integer; ExceptionIfNoVariableStart, WithAsOperator: boolean ): integer; { a variable can have the form: A A.B()^.C()[]^^.D (A).B inherited A A as B } procedure RaiseIdentNotFound; begin RaiseExceptionFmt(ctsIdentExpectedButAtomFound,[GetAtom]); end; var FirstIdentifier: boolean; procedure StartVar; begin ReadNextAtom; if UpAtomIs('INHERITED') then ReadNextAtom; FirstIdentifier:=true; if (CurPos.Flag in AllCommonAtomWords) and AtomIsIdentifier(true) then begin FirstIdentifier:=false; ReadNextAtom; end; end; begin MoveCursorToCleanPos(StartPos); StartVar; repeat case CurPos.Flag of cafRoundBracketOpen: begin ReadTilBracketClose(true); FirstIdentifier:=false; end; cafPoint: begin if FirstIdentifier and ExceptionIfNoVariableStart then RaiseIdentNotFound; ReadNextAtom; AtomIsIdentifier(true); end; cafEdgedBracketOpen: begin if FirstIdentifier and ExceptionIfNoVariableStart then RaiseIdentNotFound; ReadTilBracketClose(true); end; else if AtomIsChar('^') then begin if FirstIdentifier and ExceptionIfNoVariableStart then RaiseIdentNotFound; end else if UpAtomIs('AS') then begin if not WithAsOperator then break; StartVar; UndoReadNextAtom; end else break; end; ReadNextAtom; until false; if LastAtoms.Count>0 then UndoReadNextAtom else MoveCursorToCleanPos(StartPos); Result:=CurPos.EndPos; end; function TFindDeclarationTool.FindStartOfTerm(EndPos: integer; InType: boolean ): integer; { a variable can be combinations of 1. A.B 2. A().B 3. inherited A 4. A[]. 5. A[].B 6. A^. 7. (A). 8. (A as B) 9. (@A) 10. A()[] 11. nothing (e.g. cursor behind semicolon, keyword or closing bracket) } procedure RaiseIdentNotFound; begin RaiseExceptionFmt(ctsIdentExpectedButAtomFound,[GetAtom]); end; var CurAtom, NextAtom: TAtomPosition; NextAtomType, CurAtomType: TVariableAtomType; StartPos: LongInt; begin StartPos:=FindStartOfAtom(Src,EndPos); MoveCursorToCleanPos(StartPos); NextAtom:=CurPos; if not IsSpaceChar[Src[StartPos]] then ReadNextAtom; NextAtomType:=GetCurrentAtomType; repeat ReadPriorAtom; CurAtom:=CurPos; CurAtomType:=GetCurrentAtomType; //DebugLn(['TFindDeclarationTool.FindStartOfTerm ',GetAtom,' Cur=',VariableAtomTypeNames[CurAtomType],' Next=',VariableAtomTypeNames[NextAtomType]]); if CurAtomType in [vatRoundBracketClose,vatEdgedBracketClose] then begin if NextAtomType in [vatRoundBracketOpen,vatRoundBracketClose, vatEdgedBracketOpen,vatEdgedBracketClose,vatPoint,vatUp, vatAS,vatNone,vatSpace] then begin ReadBackTilBracketOpen(true); CurAtom.StartPos:=CurPos.StartPos; end else begin Result:=NextAtom.StartPos; exit; end; end; // check if CurAtom belongs to variable if CurAtomType=vatINHERITED then begin Result:=CurAtom.StartPos; exit; end; if (CurAtomType in [vatAS,vatKeyword]) then begin Result:=NextAtom.StartPos; exit; end; if (CurAtomType=vatUp) and InType then begin Result:=NextAtom.StartPos; exit; end; if (not (CurAtomType in [vatIdentifier,vatPreDefIdentifier,vatPoint,vatUp, vatEdgedBracketClose,vatRoundBracketClose])) or ((CurAtomType in [vatIdentifier,vatPreDefIdentifier,vatNone]) and (NextAtomType in [vatIdentifier,vatPreDefIdentifier])) or ((CurAtomType in [vatNone]) and (NextAtomType in [vatIdentifier,vatPreDefIdentifier, vatRoundBracketClose])) then begin if NextAtom.StartPos>=EndPos then begin // no token belongs to a variable (e.g. ; ;) Result:=EndPos; end else begin // the next atom is the start of the variable if (not (NextAtomType in [vatSpace,vatIdentifier,vatPreDefIdentifier, vatRoundBracketClose,vatEdgedBracketClose,vatAddrOp])) then begin MoveCursorToCleanPos(NextAtom.StartPos); ReadNextAtom; RaiseIdentNotFound; end; Result:=NextAtom.StartPos; end; exit; end; NextAtom:=CurAtom; NextAtomType:=CurAtomType; until false; end; function TFindDeclarationTool.NodeTermInType(Node: TCodeTreeNode): boolean; begin if Node=nil then exit(false); Result:=not (Node.Desc in AllPascalStatements); end; function TFindDeclarationTool.FindExpressionTypeOfTerm( StartPos, EndPos: integer; Params: TFindDeclarationParams; WithAsOperator: boolean): TExpressionType; { examples 1. A.B 2. A().B 3. inherited A 4. A[] 5. A[].B 6. A^. 7. (A). 8. (A as B) 9. (@A) 10. A as B } type TIsIdentEndOfVar = (iieovYes, iieovNo, iieovUnknown); var CurAtomType, NextAtomType, LastAtomType: TVariableAtomType; CurAtom, NextAtom: TAtomPosition; CurAtomBracketEndPos: integer; StartContext: TFindContext; OldInput: TFindDeclarationInput; StartFlags: TFindDeclarationFlags; IsIdentEndOfVar: TIsIdentEndOfVar; ExprType: TExpressionType; procedure RaiseIdentExpected; begin RaiseExceptionFmt(ctsStrExpectedButAtomFound,[ctsIdentifier,GetAtom]); end; procedure RaiseIdentNotFound; begin RaiseExceptionFmt(ctsIdentifierNotFound,[GetAtom]); end; procedure RaiseIllegalQualifierFound; begin RaiseExceptionFmt(ctsIllegalQualifier,[GetAtom]); end; procedure RaisePointNotFound; begin RaiseExceptionFmt(ctsStrExpectedButAtomFound,['.',GetAtom]); end; function InitAtomQueue: boolean; procedure RaiseInternalError; begin RaiseException('internal codetool error: FindExpressionTypeOfVariable ' +' StartPos='+IntToStr(StartPos)+' EndPos='+IntToStr(EndPos)); end; begin Result:=false; if StartPos<1 then StartPos:=FindStartOfTerm(EndPos,NodeTermInType(Params.ContextNode)) else if EndPos<1 then EndPos:=FindEndOfTerm(StartPos,true,WithAsOperator); //DebugLn(['InitAtomQueue StartPos=',StartPos,'=',dbgstr(copy(Src,StartPos,10)),' EndPos=',dbgstr(copy(Src,EndPos,10))]); if (StartPos<1) then RaiseInternalError; if StartPos>SrcLen then exit; if StartPos=EndPos then begin // e.g. cursor behind semicolon, keyword or closing bracket exit; end; {$IFDEF ShowExprEval} DebugLn([' InitAtomQueue StartPos=',StartPos,' EndPos=',EndPos,' Expr="',copy(Src,StartPos,EndPos-StartPos),'"']); {$ENDIF} LastAtomType:=vatNone; MoveCursorToCleanPos(StartPos); ReadNextAtom; if CurPos.StartPos>SrcLen then exit; CurAtom:=CurPos; CurAtomType:=GetCurrentAtomType; if CurAtomType in [vatRoundBracketOpen,vatEdgedBracketOpen] then ReadTilBracketClose(true); CurAtomBracketEndPos:=CurPos.EndPos; ReadNextAtom; NextAtom:=CurPos; if NextAtom.EndPos<=EndPos then NextAtomType:=GetCurrentAtomType else NextAtomType:=vatSpace; MoveCursorToCleanPos(CurAtom.StartPos); IsIdentEndOfVar:=iieovUnknown; Result:=true; end; procedure ReadNextExpressionAtom; begin LastAtomType:=CurAtomType; CurAtom:=NextAtom; CurAtomType:=NextAtomType; MoveCursorToCleanPos(NextAtom.StartPos); ReadNextAtom; if CurAtomType in [vatRoundBracketOpen,vatEdgedBracketOpen] then ReadTilBracketClose(true); CurAtomBracketEndPos:=CurPos.EndPos; ReadNextAtom; NextAtom:=CurPos; if NextAtom.EndPos<=EndPos then NextAtomType:=GetCurrentAtomType else NextAtomType:=vatSpace; MoveCursorToCleanPos(CurAtom.StartPos); IsIdentEndOfVar:=iieovUnknown; end; function IsIdentifierEndOfVariable: boolean; var BehindFuncAtomType: TVariableAtomType; begin if IsIdentEndOfVar=iieovUnknown then begin if CurAtom.Flag=cafWord then begin MoveCursorToCleanPos(CurAtom.EndPos); ReadNextAtom; if AtomIsChar('(') then begin ReadTilBracketClose(true); ReadNextAtom; end; if CurPos.StartPosnil]); if (ExprType.Context.Node<>nil) then begin // check if at the end of the variable if IsIdentifierEndOfVariable and (fdfFindVariable in StartFlags) then // the variable is wanted, not its type exit; if (ExprType.Context.Node.Desc=ctnProperty) and ExprType.Context.Tool.PropertyNodeHasParamList(ExprType.Context.Node) then begin // the parameter list is resolved with the [] operators exit; end; // find base type Exclude(Params.Flags,fdfFunctionResult); Include(Params.Flags,fdfEnumIdentifier); {$IFDEF ShowExprEval} DebugLn(' ResolveBaseTypeOfIdentifier BEFORE ExprType=',ExprTypeToString(ExprType)); {$ENDIF} ExprType:=ExprType.Context.Tool.ConvertNodeToExpressionType( ExprType.Context.Node,Params); {$IFDEF ShowExprEval} DebugLn(' ResolveBaseTypeOfIdentifier AFTER ExprType=',ExprTypeToString(ExprType)); {$ENDIF} if (ExprType.Desc=xtContext) and (ExprType.Context.Node.Desc in [ctnProcedure,ctnProcedureHead]) then begin // check if this is a function ProcNode:=ExprType.Context.Node; if ProcNode.Desc=ctnProcedureHead then ProcNode:=ProcNode.Parent; ExprType.Context.Tool.BuildSubTreeForProcHead(ProcNode.FirstChild, FuncResultNode); if (FuncResultNode<>nil) or ExprType.Context.Tool.NodeIsConstructor(ProcNode) then begin // it is function or a constructor // -> use the result type instead of the function if IsIdentifierEndOfVariable then begin // this function identifier is the end of the variable if not (fdfFunctionResult in StartFlags) then exit; end; Include(Params.Flags,fdfFunctionResult); ExprType:=ExprType.Context.Tool.ConvertNodeToExpressionType( ProcNode,Params); end; end; end; end; procedure ResolveIdentifier; var ProcNode: TCodeTreeNode; IdentFound: boolean; OldFlags: TFindDeclarationFlags; begin // for example 'AnObject[3]' // check special identifiers 'Result' and 'Self' IdentFound:=false; if (ExprType.Context.Node<>nil) and (ExprType.Context.Node.Desc in AllPascalStatements) then begin if CompareSrcIdentifiers(CurAtom.StartPos,'SELF') then begin // SELF in a method is the object itself // -> check if in a method or nested proc of a method ProcNode:=ExprType.Context.Node; while (ProcNode<>nil) do begin if (ProcNode.Desc=ctnProcedure) and NodeIsMethodBody(ProcNode) then break; ProcNode:=ProcNode.Parent; end; if (ProcNode<>nil) and ExprType.Context.Tool.FindClassOfMethod(ProcNode,Params, not IsIdentifierEndOfVariable) then begin ExprType.Desc:=xtContext; ExprType.Context:=CreateFindContext(Params); IdentFound:=true; end; end else if CompareSrcIdentifiers(CurAtom.StartPos,'RESULT') then begin // RESULT has a special meaning in a function // -> check if in a function ProcNode:=ExprType.Context.Node.GetNodeOfType(ctnProcedure); if (ProcNode<>nil) then begin if IsIdentifierEndOfVariable and (fdfFindVariable in StartFlags) then begin ExprType.Desc:=xtContext; ExprType.Context.Node:=ProcNode.FirstChild; end else begin OldFlags:=Params.Flags; Params.Flags:=Params.Flags+[fdfFunctionResult,fdfFindChilds]; ExprType.Desc:=xtContext; ExprType.Context:=FindBaseTypeOfNode(Params,ProcNode); Params.Flags:=OldFlags; end; exit; end; end; end; // find sub identifier if not IdentFound then begin Params.Save(OldInput); // build new param flags for sub identifiers Params.Flags:=[fdfSearchInAncestors,fdfExceptionOnNotFound] +(fdfGlobals*Params.Flags); Params.ContextNode:=ExprType.Context.Node; if ExprType.Context.Node=StartContext.Node then begin // there is no special context -> search in parent contexts too Params.Flags:=Params.Flags+[fdfSearchInParentNodes,fdfIgnoreCurContextNode]; end else begin // only search in special context Params.Flags:=Params.Flags+[fdfIgnoreUsedUnits]; end; // check identifier for overloaded procs if (NextAtomType<>vatRoundBracketOpen) or (IsIdentifierEndOfVariable and (fdfIgnoreOverloadedProcs in StartFlags)) then Include(Params.Flags,fdfIgnoreOverloadedProcs) else Exclude(Params.Flags,fdfIgnoreOverloadedProcs); // search ... Params.SetIdentifier(Self,@Src[CurAtom.StartPos],@CheckSrcIdentifier); {$IFDEF ShowExprEval} DebugLn(' ResolveIdentifier Ident="',GetIdentifier(Params.Identifier),'" ContextNode=',Params.ContextNode.DescAsString,' ',dbgstr(copy(ExprType.Context.Tool.Src,Params.ContextNode.StartPos,15))); {$ENDIF} if ExprType.Context.Tool.FindIdentifierInContext(Params) then begin if not Params.NewCodeTool.NodeIsConstructor(Params.NewNode) then begin ExprType.Desc:=xtContext; ExprType.Context:=CreateFindContext(Params); end else begin // it's a constructor -> keep the class end; Params.Load(OldInput,true); end else begin // predefined identifier Params.Load(OldInput,true); ExprType:=FindExpressionTypeOfPredefinedIdentifier(CurAtom.StartPos, Params); end; // ToDo: check if identifier in 'Protected' section end; end; procedure ResolvePoint; var NewCodeTool: TFindDeclarationTool; UnitNameAtom: TAtomPosition; InAtom: TAtomPosition; NewNode: TCodeTreeNode; begin // for example 'A.B' if (not (NextAtomType in [vatSpace,vatIdentifier,vatPreDefIdentifier])) then begin MoveCursorToCleanPos(NextAtom.StartPos); ReadNextAtom; RaiseIdentExpected; end; ResolveBaseTypeOfIdentifier; if (ExprType.Context.Node=nil) then begin MoveCursorToCleanPos(CurAtom.StartPos); ReadNextAtom; RaiseIllegalQualifierFound; end; if (ExprType.Context.Node.Desc in AllUsableSourceTypes) then begin // identifier in front of the point is a unit name {$IFDEF ShowExprEval} debugln(['ResolvePoint unit -> interface node']); {$ENDIF} ExprType.Context.Node:=ExprType.Context.Tool.GetInterfaceNode; end else if (ExprType.Context.Node.Desc=ctnUseUnit) then begin // identifier in front of the point is a uses unit name {$IFDEF ShowExprEval} debugln(['ResolvePoint used unit -> interface node ',dbgstr(ExprType.Context.Tool.ExtractNode(ExprType.Context.Node,[]))]); {$ENDIF} ExprType.Context.Tool.MoveCursorToCleanPos(ExprType.Context.Node.StartPos); ReadNextAtom; UnitNameAtom:=CurPos; ReadNextAtom; if UpAtomIs('IN') then begin ReadNextAtom; InAtom:=CurPos; end else InAtom.StartPos:=0; NewCodeTool:=OpenCodeToolForUnit(UnitNameAtom,InAtom,true); NewCodeTool.BuildInterfaceIdentifierCache(true); NewNode:=NewCodeTool.FindInterfaceNode; ExprType.Context.Tool:=NewCodeTool; ExprType.Context.Node:=NewNode; end else if (ExprType.Context.Node.Desc=ctnClassOfType) then begin // 'class of' plus '.' => jump to the class ExprType.Desc:=xtContext; Params.Flags:=Params.Flags+[fdfFunctionResult,fdfFindChilds]; ExprType.Context:=ExprType.Context.Tool.FindBaseTypeOfNode(Params, ExprType.Context.Node.FirstChild); end else if (Scanner.CompilerMode=cmDELPHI) and (ExprType.Desc=xtContext) and (ExprType.Context.Node.Desc=ctnPointerType) and (ExprType.Context.Node<>StartContext.Node) then begin // Delphi knows . as shortcut for ^. // -> check for pointer type // left side of expression has defined a special context // => this '.' is a dereference ExprType.Desc:=xtContext; Params.Flags:=Params.Flags+[fdfFunctionResult,fdfFindChilds]; ExprType.Context:=ExprType.Context.Tool.FindBaseTypeOfNode(Params, ExprType.Context.Node.FirstChild); end else if ExprType.Context.Node.Desc in AllPointContexts then begin // ok, allowed end else begin // not allowed MoveCursorToCleanPos(CurAtom.StartPos); ReadNextAtom; RaiseIllegalQualifierFound; end; end; procedure ResolveAs; begin // for example 'A as B' if (not (NextAtomType in [vatSpace,vatIdentifier,vatPreDefIdentifier])) then begin MoveCursorToCleanPos(NextAtom.StartPos); ReadNextAtom; RaiseIdentExpected; end; // 'as' is a type cast, so the left side is irrelevant // -> context is default context ExprType.Desc:=xtContext; ExprType.Context:=StartContext; end; procedure ResolveUp; begin // for example: // 1. 'PInt = ^integer' pointer type // 2. a^ dereferencing if (not (NextAtomType in [vatSpace,vatPoint,vatUp,vatAS,vatEdgedBracketOpen])) or ((ExprType.Context.Node=nil) and (ExprType.Desc<>xtPointer)) then begin MoveCursorToCleanPos(NextAtom.StartPos); ReadNextAtom; RaiseIllegalQualifierFound; end; ResolveBaseTypeOfIdentifier; if (ExprType.Desc=xtPointer) then exit; if (ExprType.Context.Node<>StartContext.Node) then begin // left side of expression has defined a special context // => this '^' is a dereference if (not (NextAtomType in [vatSpace,vatPoint,vatAS,vatUP,vatEdgedBracketOpen])) then begin MoveCursorToCleanPos(NextAtom.StartPos); ReadNextAtom; RaisePointNotFound; end; if ExprType.Context.Node.Desc<>ctnPointerType then begin MoveCursorToCleanPos(CurAtom.StartPos); RaiseExceptionFmt(ctsIllegalQualifier,['^']); end; ExprType.Desc:=xtContext; ExprType.Context:=ExprType.Context.Tool.FindBaseTypeOfNode(Params, ExprType.Context.Node.FirstChild); end else if NodeHasParentOfType(ExprType.Context.Node,ctnPointerType) then begin // this is a pointer type definition // -> the default context is ok end; end; procedure ResolveEdgedBracketOpen; { for example: a[] this could be: 1. ranged array e.g. array[1..2] of 2. dynamic array e.g. array of integer 3. variant array e.g. array of const 4. indexed pointer e.g. PInteger[1] 5. default property e.g. Items[Index: integer] 6. indexed property e.g. Items[Index: integer] 7. string character e.g. string[3] } procedure RaiseTypeIdentNotFound; begin ExprType.Context.Tool.RaiseExceptionFmt(ctsStrExpectedButAtomFound, [ctsTypeIdentifier,ExprType.Context.Tool.GetAtom]); end; procedure RaiseIdentInCurContextNotFound; begin ExprType.Context.Tool.RaiseExceptionFmt(ctsStrExpectedButAtomFound, [ctsIdentifier,GetAtom]); end; begin if not (NextAtomType in [vatSpace,vatPoint,vatAs,vatUp,vatRoundBracketClose, vatRoundBracketOpen,vatEdgedBracketClose,vatEdgedBracketOpen]) or ((ExprType.Context.Node=nil) and (not (ExprType.Desc in xtAllStringTypes))) then begin MoveCursorToCleanPos(NextAtom.StartPos); ReadNextAtom; RaiseIllegalQualifierFound; end; ResolveBaseTypeOfIdentifier; if ExprType.Desc in xtAllStringTypes then begin ExprType.Desc:=xtChar; ExprType.Context.Node:=nil; exit; end; if ExprType.Desc in xtAllWideStringTypes then begin ExprType.Desc:=xtWideChar; ExprType.Context.Node:=nil; exit; end; //DebugLn(['ResolveEdgedBracketOpen ',ExprTypeToString(ExprType)]); case ExprType.Context.Node.Desc of ctnOpenArrayType,ctnRangedArrayType: begin // the array type is the last child node //debugln('ResolveEdgedBracketOpen Open/RangedArray LastChild=',ExprType.Context.Node.LastChild.DescAsString); if ExprType.Context.Node.LastChild.Desc=ctnOfConstType then begin // 'array of const'; the array type is 'TVarRec' // => search 'TVarRec' Params.Save(OldInput); Params.Flags:=[fdfSearchInParentNodes,fdfIgnoreCurContextNode, fdfExceptionOnNotFound] +fdfGlobals*Params.Flags -[fdfTopLvlResolving]; // special identifier for TVarRec Params.SetIdentifier(Self,'tvarrec',nil); Params.ContextNode:=ExprType.Context.Node; ExprType.Context.Tool.FindIdentifierInContext(Params); ExprType.Context:=Params.NewCodeTool.FindBaseTypeOfNode(Params, Params.NewNode); Params.Load(OldInput,true); end else begin ExprType.Context:=ExprType.Context.Tool.FindBaseTypeOfNode(Params, ExprType.Context.Node.LastChild); end; end; ctnPointerType: // the pointer type is the only child node ExprType.Context:=ExprType.Context.Tool.FindBaseTypeOfNode(Params, ExprType.Context.Node.FirstChild); ctnClass, ctnClassInterface, ctnDispinterface, ctnObject, ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass, ctnProperty, ctnGlobalProperty: begin if ExprType.Context.Node.Desc in AllClasses then begin // search default property of the class / interface Params.Save(OldInput); Params.Flags:=[fdfSearchInAncestors,fdfExceptionOnNotFound] +fdfGlobals*Params.Flags; // special identifier for default property Params.SetIdentifier(Self,@Src[CurAtom.StartPos],nil); Params.ContextNode:=ExprType.Context.Node; ExprType.Context.Tool.FindIdentifierInContext(Params); ExprType.Context:=CreateFindContext(Params); Params.Load(OldInput,true); end; // find base type of property if ExprType.Context.Tool.ReadTilTypeOfProperty(ExprType.Context.Node) then begin // property has type Params.Save(OldInput); with ExprType.Context.Tool do Params.SetIdentifier(ExprType.Context.Tool, @Src[CurPos.StartPos],nil); Params.Flags:=[fdfSearchInParentNodes,fdfExceptionOnNotFound] +(fdfGlobals*Params.Flags); Params.ContextNode:=ExprType.Context.Node.Parent; if ExprType.Context.Tool.FindIdentifierInContext(Params) then begin // only types allowed if Params.NewNode.Desc=ctnTypeDefinition then begin ExprType.Context:=Params.NewCodeTool.FindBaseTypeOfNode(Params, Params.NewNode); end else if Params.NewNode.Desc=ctnGenericParameter then begin ExprType.Context.Tool:=Params.NewCodeTool; ExprType.Context.Node:=Params.NewNode; end else begin // not a type ExprType.Context.Tool.ReadTilTypeOfProperty(ExprType.Context.Node); RaiseTypeIdentNotFound; end; end else begin // predefined identifier end; Params.Load(OldInput,true); end else RaiseIdentInCurContextNotFound; end; ctnIdentifier: begin MoveCursorToNodeStart(ExprType.Context.Node); ReadNextAtom; if UpAtomIs('STRING') or UpAtomIs('ANSISTRING') or UpAtomIs('SHORTSTRING') then begin ExprType.Desc:=xtChar; ExprType.Context.Node:=nil; exit; end else if UpAtomIs('WIDESTRING') or UpAtomIs('UNICODESTRING') then begin ExprType.Desc:=xtWideChar; ExprType.Context.Node:=nil; exit; end else begin MoveCursorToCleanPos(CurAtom.StartPos); ReadNextAtom; RaiseIllegalQualifierFound; end; end; else MoveCursorToCleanPos(CurAtom.StartPos); ReadNextAtom; RaiseIllegalQualifierFound; end; end; procedure ResolveRoundBracketOpen; begin { for example: (a+b) expression bracket: the type is the result type of the expression. a() typecast or function } if not (NextAtomType in [vatSpace,vatPoint,vatAs,vatUp,vatRoundBracketClose, vatRoundBracketOpen,vatEdgedBracketClose,vatEdgedBracketOpen]) then begin MoveCursorToCleanPos(NextAtom.StartPos); ReadNextAtom; RaiseIllegalQualifierFound; end; if LastAtomType<>vatNone then begin // typecast or function end else begin // expression ExprType:=FindExpressionResultType(Params,CurAtom.StartPos+1, CurAtomBracketEndPos-1); end; end; procedure ResolveINHERITED; var ProcNode: TCodeTreeNode; ClassOfMethodContext: TFindContext; HasIdentifier: Boolean; begin // for example: inherited A; // inherited skips the class and begins to search in the ancestor class if (ExprType.Context.Node<>StartContext.Node) or (ExprType.Context.Node=nil) then begin MoveCursorToCleanPos(CurAtom.StartPos); RaiseIllegalQualifierFound; end; if (not NodeIsInAMethod(ExprType.Context.Node)) then begin MoveCursorToCleanPos(CurAtom.StartPos); RaiseException(ctsInheritedKeywordOnlyAllowedInMethods); end; HasIdentifier:=NextAtom.EndPos<=EndPos; if HasIdentifier then begin if (not (NextAtomType in [vatIdentifier,vatPreDefIdentifier])) then begin MoveCursorToCleanPos(NextAtom.StartPos); ReadNextAtom; RaiseIdentExpected; end; ReadNextExpressionAtom; end; {$IFDEF ShowExprEval} DebugLn(' ResolveINHERITED CurAtomType=', VariableAtomTypeNames[CurAtomType], ' CurAtom="',copy(Src,CurAtom.StartPos,CurAtom.EndPos-CurAtom.StartPos),'"'); {$ENDIF} // find ancestor of class of method ProcNode:=ExprType.Context.Node.GetNodeOfType(ctnProcedure); Params.Save(OldInput); Params.Flags:=[fdfExceptionOnNotFound] +fdfGlobals*Params.Flags; ExprType.Context.Tool.FindClassOfMethod(ProcNode,Params,true); ClassOfMethodContext:=CreateFindContext(Params); // find class ancestor Params.Flags:=[fdfSearchInParentNodes,fdfExceptionOnNotFound] +fdfGlobals*Params.Flags; ClassOfMethodContext.Tool.FindAncestorOfClass(ClassOfMethodContext.Node, Params,true); if HasIdentifier then begin // search identifier only in class ancestor Params.Load(OldInput,false); Params.SetIdentifier(Self,@Src[CurAtom.StartPos],@CheckSrcIdentifier); Params.ContextNode:=Params.NewNode; Params.Flags:=Params.Flags-[fdfSearchInParentNodes] +[fdfExceptionOnNotFound,fdfSearchInAncestors]; Params.NewCodeTool.FindIdentifierInContext(Params); ExprType.Context:=CreateFindContext(Params); Params.Load(OldInput,true); ResolveBaseTypeOfIdentifier; end else begin // the keyword 'inherited' is the last atom // return the ancestor class context ExprType.Context:=CreateFindContext(Params); end; end; begin Result:=CleanExpressionType; StartFlags:=Params.Flags; StartContext.Node:=Params.ContextNode; StartContext.Tool:=Self; {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.FindExpressionTypeOfTerm]', ' Flags=[',FindDeclarationFlagsAsString(Params.Flags),']', ' StartContext=',StartContext.Node.DescAsString,'=',dbgstr(copy(StartContext.Tool.Src,StartContext.Node.StartPos,15)) ); {$ENDIF} if not InitAtomQueue then exit; {$IFDEF ShowExprEval} DebugLn(['TFindDeclarationTool.FindExpressionTypeOfTerm Expression="',copy(Src,StartPos,EndPos-StartPos),'"']); {$ENDIF} ExprType.Desc:=xtContext; ExprType.SubDesc:=xtNone; ExprType.Context:=StartContext; repeat {$IFDEF ShowExprEval} DebugLn(' FindExpressionTypeOfTerm CurAtomType=', VariableAtomTypeNames[CurAtomType],' CurAtom="',GetAtom(CurAtom),'"', ' ExprType=',ExprTypeToString(ExprType)); {$ENDIF} case CurAtomType of vatIdentifier, vatPreDefIdentifier: ResolveIdentifier; vatPoint: ResolvePoint; vatAS: ResolveAs; vatUP: ResolveUp; vatEdgedBracketOpen: ResolveEdgedBracketOpen; vatRoundBracketOpen: ResolveRoundBracketOpen; vatINHERITED: ResolveINHERITED; end; ReadNextExpressionAtom; until CurAtom.EndPos>EndPos; Result:=ExprType; if (Result.Desc=xtContext) and (not (fdfFindVariable in StartFlags)) then Result:=Result.Context.Tool.ConvertNodeToExpressionType( Result.Context.Node,Params); {$IFDEF ShowExprEval} DebugLn(' FindExpressionTypeOfTerm Result=',ExprTypeToString(Result)); {$ENDIF} end; function TFindDeclarationTool.FindEndOfExpression(StartPos: integer): integer; begin MoveCursorToCleanPos(StartPos); Result:=CurPos.StartPos; repeat ReadNextAtom; // read till statement end if (CurPos.StartPos>SrcLen) or (CurPos.Flag in [cafSemicolon,cafComma,cafEnd, cafRoundBracketClose,cafEdgedBracketClose]) or (AtomIsKeyWord and not IsKeyWordInConstAllowed.DoItCaseInsensitive(Src, CurPos.StartPos,CurPos.EndPos-CurPos.StartPos)) then begin break; end else if CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen] then begin ReadTilBracketClose(true); end; Result:=CurPos.EndPos; until false; end; function TFindDeclarationTool.ConvertNodeToExpressionType(Node: TCodeTreeNode; Params: TFindDeclarationParams): TExpressionType; procedure ConvertIdentifierAtCursor; begin if WordIsPredefinedIdentifier.DoItCaseInsensitive(Src,CurPos.StartPos, CurPos.EndPos-CurPos.StartPos) then begin // predefined identifiers ConvertNodeToExpressionType:=FindExpressionTypeOfPredefinedIdentifier( CurPos.StartPos,Params); end; end; var BaseContext: TFindContext; OldInput: TFindDeclarationInput; begin {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF} {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.ConvertNodeToExpressionType] A', ' Node=',Node.DescAsString); {$ENDIF} BaseContext:=FindBaseTypeOfNode(Params,Node); Node:=BaseContext.Node; if BaseContext.Tool<>Self then begin Result:=BaseContext.Tool.ConvertNodeToExpressionType(Node,Params); exit; end; Result:=CleanExpressionType; Result.Desc:=xtContext; Result.Context:=CreateFindContext(Self,Node); {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.ConvertNodeToExpressionType] B', ' Expr=',ExprTypeToString(Result)); {$ENDIF} case Node.Desc of ctnRangeType: begin // range type -> convert to special expression type // ToDo: ppu, ppw, dcu files MoveCursorToNodeStart(Node); // ToDo: check for circles Params.Save(OldInput); Params.ContextNode:=Node; Result:=ReadOperandTypeAtCursor(Params); Params.Load(OldInput,true); Result.Context:=CreateFindContext(Self,Node); end; ctnConstDefinition: begin // const -> convert to special expression type // ToDo: ppu, ppw, dcu files MoveCursorToNodeStart(Node); ReadNextAtom; if not AtomIsIdentifier(false) then exit; ReadNextAtom; if not (CurPos.Flag in [cafEqual,cafColon]) then exit; ReadNextAtom; // ToDo: check for circles Params.Save(OldInput); Params.ContextNode:=Node; Result:=ReadOperandTypeAtCursor(Params); Params.Load(OldInput,true); Result.Context:=CreateFindContext(Self,Node); end; ctnIdentifier: begin // ToDo: ppu, ppw, dcu files MoveCursorToNodeStart(Node); ReadNextAtom; ConvertIdentifierAtCursor; end; ctnProperty,ctnGlobalProperty: begin // ToDo: ppu, ppw, dcu files ExtractPropType(Node,false,true); if CurPos.Flag<>cafEdgedBracketOpen then ConvertIdentifierAtCursor; end; ctnConstant: begin // ToDo: ppu, ppw, dcu files MoveCursorToNodeStart(Node); Params.Save(OldInput); Params.ContextNode:=Node; Result:=ReadOperandTypeAtCursor(Params); Params.Load(OldInput,true); Result.Context:=CreateFindContext(Self,Node); end; end; end; function TFindDeclarationTool.ReadOperandTypeAtCursor( Params: TFindDeclarationParams; MaxEndPos: integer): TExpressionType; { internally used by FindExpressionResultType after reading, the cursor will be on the next atom } var EndPos, SubStartPos: integer; procedure ReadEdgedBracketOperand; procedure RaiseConstExpected; begin RaiseExceptionFmt(ctsStrExpectedButAtomFound,[ctsConstant,GetAtom]); end; begin // 'set' constant SubStartPos:=CurPos.StartPos; ReadNextAtom; if not AtomIsChar(']') then begin Result:=ReadOperandTypeAtCursor(Params); {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.ReadOperandTypeAtCursor] Set of ', ExpressionTypeDescNames[Result.Desc]); if Result.Desc=xtContext then DebugLn(' Result.Context.Node=',Result.Context.Node.DescAsString); {$ENDIF} end else begin // empty set '[]' Result.Desc:=xtNone; end; Result.SubDesc:=Result.Desc; Result.Desc:=xtConstSet; MoveCursorToCleanPos(SubStartPos); ReadNextAtom; ReadTilBracketClose(true); MoveCursorToCleanPos(CurPos.EndPos); end; procedure RaiseIdentExpected; begin RaiseExceptionFmt(ctsStrExpectedButAtomFound,[ctsIdentifier,GetAtom]); end; var OldFlags: TFindDeclarationFlags; begin Result:=CleanExpressionType; if CurPos.StartPos=CurPos.EndPos then ReadNextAtom; // read unary operators which have no effect on the type: +, -, not while AtomIsChar('+') or AtomIsChar('-') or UpAtomIs('NOT') do ReadNextAtom; {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.ReadOperandTypeAtCursor] A Atom=',GetAtom); {$ENDIF} if (AtomIsIdentifier(false)) or (CurPos.Flag=cafRoundBracketOpen) or UpAtomIs('INHERITED') then begin // read variable SubStartPos:=CurPos.StartPos; EndPos:=FindEndOfTerm(SubStartPos,false,true); if EndPos>MaxEndPos then EndPos:=MaxEndPos; OldFlags:=Params.Flags; Params.Flags:=(Params.Flags*fdfGlobals)+[fdfFunctionResult]; Result:=FindExpressionTypeOfTerm(SubStartPos,EndPos,Params,true); Params.Flags:=OldFlags; MoveCursorToCleanPos(EndPos); end else if UpAtomIs('NIL') then begin Result.Desc:=xtNil; ReadNextAtom; end else if AtomIsChar('[') then begin ReadEdgedBracketOperand; end else if AtomIsStringConstant then begin // string or char constant if AtomIsCharConstant then Result.Desc:=xtChar else Result.Desc:=xtConstString; MoveCursorToCleanPos(CurPos.EndPos); end else if AtomIsNumber then begin // ordinal or real constant if AtomIsRealNumber then Result.Desc:=xtConstReal else Result.Desc:=xtConstOrdInteger; MoveCursorToCleanPos(CurPos.EndPos); end else if AtomIsChar('@') then begin // a simple pointer or a PChar or an event ReadNextAtom; if CurPos.Flag=cafWord then begin SubStartPos:=CurPos.StartPos; EndPos:=FindEndOfTerm(SubStartPos,false,true); if EndPos>MaxEndPos then EndPos:=MaxEndPos; OldFlags:=Params.Flags; Params.Flags:=(Params.Flags*fdfGlobals)-[fdfFunctionResult]; Result:=FindExpressionTypeOfTerm(SubStartPos,EndPos,Params,true); Params.Flags:=OldFlags; MoveCursorToCleanPos(EndPos); end else begin MoveCursorToCleanPos(CurPos.StartPos); Result:=ReadOperandTypeAtCursor(Params); end; if (Result.Desc=xtContext) or ((Result.Context.Node<>nil) and (Result.Context.Node.Desc=ctnProcedure)) then begin Result.SubDesc:=Result.Desc; Result.Desc:=xtPointer; end else if (Result.Desc=xtChar) then begin Result.SubDesc:=xtNone; Result.Desc:=xtPChar end else begin Result.SubDesc:=xtNone; Result.Context:=CleanFindContext; Result.Desc:=xtPointer; end; end else RaiseIdentExpected; {$IFDEF ShowExprEval} DbgOut('[TFindDeclarationTool.ReadOperandTypeAtCursor] END ', ExpressionTypeDescNames[Result.Desc]); if Result.Context.Node<>nil then DbgOut(' Context.Node=',Result.Context.Node.DescAsString) else DbgOut(' Context.Node=nil'); DebugLn(''); {$ENDIF} end; function TFindDeclarationTool.FindExpressionTypeOfPredefinedIdentifier( StartPos: integer; Params: TFindDeclarationParams): TExpressionType; var IdentPos: PChar; ParamList: TExprTypeList; ParamNode: TCodeTreeNode; SubParams: TFindDeclarationParams; NewTool: TFindDeclarationTool; begin Result:=CleanExpressionType; IdentPos:=@Src[StartPos]; Result.Desc:=PredefinedIdentToExprTypeDesc(IdentPos); {$IFDEF ShowExprEval} debugln('TFindDeclarationTool.FindExpressionTypeOfPredefinedIdentifier ', ExpressionTypeDescNames[Result.Desc]); {$ENDIF} ParamList:=nil; try case Result.Desc of xtCompilerFunc: begin if not (Params.ContextNode.Desc in AllPascalStatements) then exit; MoveCursorToCleanPos(StartPos); ReadNextAtom; ReadNextAtom; if not AtomIsChar('(') then exit; ParamList:=CreateParamExprListFromStatement(CurPos.StartPos,Params); if (CompareIdentifiers(IdentPos,'PREC')=0) or (CompareIdentifiers(IdentPos,'SUCC')=0) then begin // the PREC and SUCC of a expression has the same type as the expression if ParamList.Count<>1 then exit; Result:=ParamList.Items[0]; end else if (CompareIdentifiers(IdentPos,'LOW')=0) or (CompareIdentifiers(IdentPos,'HIGH')=0) then begin {$IFDEF ShowExprEval} debugln('TFindDeclarationTool.FindExpressionTypeOfPredefinedIdentifier Ident=',GetIdentifier(IdentPos)); {$ENDIF} { examples: Low(ordinal type) is the ordinal type Low(array) has type of the array items Low(set) has type of the enums } if ParamList.Count<>1 then exit; Result:=ParamList.Items[0]; if Result.Desc<>xtContext then exit; ParamNode:=Result.Context.Node; case ParamNode.Desc of ctnEnumerationType: // Low(enum) has the type of the enum if (ParamNode.Parent<>nil) and (ParamNode.Parent.Desc=ctnTypeDefinition) then Result.Context.Node:=ParamNode.Parent; ctnOpenArrayType: // array without explicit range -> open array // Low(Open array) is ordinal integer begin Result.Desc:=xtConstOrdInteger; Result.Context:=CleanFindContext; end; ctnRangedArrayType: begin // array with explicit range // Low(array[SubRange]) has the type of the subrange MoveCursorToNodeStart(ParamNode.FirstChild); Result:=ReadOperandTypeAtCursor(Params); end; else DebugLn('NOTE: unimplemented Low(type) type=',ParamNode.DescAsString); end; end else if (CompareIdentifiers(IdentPos,'LENGTH')=0) then begin if ParamList.Count<>1 then exit; Result.Desc:=xtConstOrdInteger; end else if (CompareIdentifiers(IdentPos,'COPY')=0) then begin if (ParamList.Count<>3) or (Scanner.Values.IsDefined('VER1_0')) then exit; Result.Desc:=xtString; end else if (CompareIdentifiers(IdentPos,'OBJCSELECTOR')=0) then begin // return type is System.SEL NewTool:=FindCodeToolForUsedUnit('system','',true); if NewTool=nil then exit; SubParams:=TFindDeclarationParams.Create; try SubParams.Identifier:='SEL'#0; if (not NewTool.FindIdentifierInInterface(Self,SubParams)) or (SubParams.NewNode=nil) then exit; Result.Desc:=xtContext; Result.Context.Node:=SubParams.NewNode; Result.Context.Tool:=SubParams.NewCodeTool; finally SubParams.Free; end; end; end; xtString: begin if (Scanner.PascalCompiler=pcDelphi) or ((Scanner.CompilerMode=cmDELPHI) or (Scanner.Values['LONGSTRINGS']='1')) then Result.Desc:=xtAnsiString; end; end; finally ParamList.Free; end; end; function TFindDeclarationTool.CalculateBinaryOperator(LeftOperand, RightOperand: TExpressionType; BinaryOperator: TAtomPosition; Params: TFindDeclarationParams): TExpressionType; begin Result:=CleanExpressionType; {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.CalculateBinaryOperator] A', ' LeftOperand=',ExpressionTypeDescNames[LeftOperand.Desc], ' Operator=',GetAtom(BinaryOperator), ' RightOperand=',ExpressionTypeDescNames[RightOperand.Desc] ); {$ENDIF} // convert Left and RightOperand contexts to expressiontype if LeftOperand.Desc=xtContext then begin LeftOperand:=LeftOperand.Context.Tool.ConvertNodeToExpressionType( LeftOperand.Context.Node,Params); end; if RightOperand.Desc=xtContext then begin RightOperand:=RightOperand.Context.Tool.ConvertNodeToExpressionType( RightOperand.Context.Node,Params); end; // ToDo: search for an overloaded operator if WordIsBooleanOperator.DoItUpperCase(Src,BinaryOperator.StartPos, BinaryOperator.EndPos-BinaryOperator.StartPos) then begin // Boolean operators // < > <= >= <> in is Result.Desc:=xtBoolean; end else if (BinaryOperator.EndPos-BinaryOperator.StartPos=1) and (Src[BinaryOperator.StartPos]='/') then begin // real division / Result.Desc:=xtConstReal; end else if WordIsOrdNumberOperator.DoItUpperCase(Src,BinaryOperator.StartPos, BinaryOperator.EndPos-BinaryOperator.StartPos) then begin // ordinal number operator // or xor and mod div shl shr Result.Desc:=xtConstOrdInteger; end else if WordIsNumberOperator.DoItUpperCase(Src,BinaryOperator.StartPos, BinaryOperator.EndPos-BinaryOperator.StartPos) then begin // number operator (or string concatenating or set cut) // + - * if (Src[BinaryOperator.StartPos]='+') and (LeftOperand.Desc in xtAllStringCompatibleTypes) then begin // string/char '+' if (RightOperand.Desc in xtAllStringCompatibleTypes) then Result.Desc:=xtConstString else begin MoveCursorToCleanPos(BinaryOperator.EndPos); ReadNextAtom; RaiseExceptionFmt(ctsIncompatibleTypesGotExpected, ['char',ExpressionTypeDescNames[RightOperand.Desc]]); end; end else if (Src[BinaryOperator.StartPos] in ['+','-','*']) and (LeftOperand.Desc=xtContext) and (LeftOperand.Context.Node<>nil) and (LeftOperand.Context.Node.Desc=ctnSetType) then begin Result:=LeftOperand; end else begin if (LeftOperand.Desc in xtAllRealTypes) or (RightOperand.Desc in xtAllRealTypes) then Result.Desc:=xtConstReal else if (LeftOperand.Desc=xtPointer) or (RightOperand.Desc=xtPointer) or ((LeftOperand.Desc=xtContext) and (LeftOperand.Context.Node.Desc=ctnPointerType)) or ((RightOperand.Desc=xtContext) and (RightOperand.Context.Node.Desc=ctnPointerType)) then Result.Desc:=xtPointer else Result.Desc:=xtConstOrdInteger; end; end else // ??? Result:=RightOperand; end; function TFindDeclarationTool.IsParamExprListCompatibleToNodeList( FirstTargetParameterNode: TCodeTreeNode; SourceExprParamList: TExprTypeList; IgnoreMissingParameters: boolean; Params: TFindDeclarationParams; CompatibilityList: TTypeCompatibilityList): TTypeCompatibility; // tests if SourceExprParamList fits into the TargetFirstParameterNode var ParamNode: TCodeTreeNode; i, MinParamCnt, MaxParamCnt: integer; ParamCompatibility: TTypeCompatibility; CompatibilityListCount: LongInt; begin {$IFDEF CheckNodeTool}CheckNodeTool(FirstTargetParameterNode);{$ENDIF} // quick check: parameter count ParamNode:=FirstTargetParameterNode; MinParamCnt:=0; while (ParamNode<>nil) and ((ParamNode.SubDesc and ctnsHasDefaultValue)=0) do begin ParamNode:=ParamNode.NextBrother; inc(MinParamCnt); end; MaxParamCnt:=MinParamCnt; while (ParamNode<>nil) do begin ParamNode:=ParamNode.NextBrother; inc(MaxParamCnt); end; {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.IsParamExprListCompatibleToNodeList] ', ' ExprParamList.Count=',dbgs(SourceExprParamList.Count), ' MinParamCnt=',dbgs(MinParamCnt),' MaxParamCnt=',dbgs(MaxParamCnt) ); try {$ENDIF} Result:=tcExact; if (SourceExprParamlist.Count>MaxParamCnt) or ((not IgnoreMissingParameters) and (SourceExprParamList.Countnil) and (inil then CompatibilityList[i]:=ParamCompatibility; if ParamCompatibility=tcIncompatible then begin Result:=tcIncompatible; exit; end else if ParamCompatibility=tcCompatible then begin Result:=tcCompatible; end; ParamNode:=ParamNode.NextBrother; inc(i); end; if (inil) then begin // there are not enough expressions for the param list // -> check if missing variables have default variables if (ParamNode.SubDesc and ctnsHasDefaultValue)>0 then begin // the rest params have default values if CompatibilityList<>nil then begin while (ParamNode<>nil) and (i incompatible Result:=tcIncompatible; end; end; {$IFDEF ShowExprEval} finally DebugLn('[TFindDeclarationTool.IsParamExprListCompatibleToNodeList] END ', ' Result=',TypeCompatibilityNames[Result],' ! ONLY VALID if no error !' ); end; {$ENDIF} end; function TFindDeclarationTool.IsParamNodeListCompatibleToExprList( TargetExprParamList: TExprTypeList; FirstSourceParameterNode: TCodeTreeNode; Params: TFindDeclarationParams; CompatibilityList: TTypeCompatibilityList): TTypeCompatibility; // tests if FirstSourceParameterNode fits (i.e. can be assigned) into // the TargetExprParamList var ParamNode: TCodeTreeNode; i, MinParamCnt, MaxParamCnt: integer; ParamCompatibility: TTypeCompatibility; SourceExprType: TExpressionType; begin {$IFDEF CheckNodeTool}CheckNodeTool(FirstSourceParameterNode);{$ENDIF} // quick check: parameter count MinParamCnt:=0; ParamNode:=FirstSourceParameterNode; while (ParamNode<>nil) do begin ParamNode:=ParamNode.NextBrother; inc(MinParamCnt); end; MaxParamCnt:=MinParamCnt; {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.IsParamNodeListCompatibleToExprList] ', ' ExprParamList.Count=',dbgs(TargetExprParamList.Count),' ', ' MinParamCnt=',dbgs(MinParamCnt),' MaxParamCnt=',dbgs(MaxParamCnt) ); try {$ENDIF} Result:=tcExact; if (TargetExprParamList.Count<>MaxParamCnt) then begin Result:=tcIncompatible; exit; end; // check each parameter for compatibility {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.IsParamNodeListCompatibleToExprList] ', ' ExprParamList=[',TargetExprParamList.AsString,']'); {$ENDIF} ParamNode:=FirstSourceParameterNode; i:=0; while (ParamNode<>nil) and (inil then CompatibilityList[i]:=ParamCompatibility; if ParamCompatibility=tcIncompatible then begin Result:=tcIncompatible; exit; end else if ParamCompatibility=tcCompatible then begin Result:=tcCompatible; end; ParamNode:=ParamNode.NextBrother; inc(i); end; if (ParamNode<>nil) or (inil) and (CurParamNode2<>nil) do begin CurParamNode1:=CurParamNode1.NextBrother; CurParamNode2:=CurParamNode2.NextBrother; end; if (CurParamNode1<>nil) or (CurParamNode2<>nil) then begin Result:=tcIncompatible; exit; end; // check each parameter OldFlags:=Params.Flags; Params.Flags:=Params.Flags-[fdfFindVariable]+[fdfIgnoreOverloadedProcs]; CurParamNode1:=FirstTargetParameterNode; CurParamNode2:=FirstSourceParameterNode; Result:=tcExact; i:=0; while (CurParamNode1<>nil) and (CurParamNode2<>nil) do begin TargetExprType:=ConvertNodeToExpressionType(CurParamNode1,Params); SourceExprType:=ConvertNodeToExpressionType(CurParamNode2,Params); ParamCompatibility:=IsBaseCompatible(TargetExprType,SourceExprType,Params); if CompatibilityList<>nil then CompatibilityList[i]:=ParamCompatibility; if ParamCompatibility=tcIncompatible then begin Result:=tcIncompatible; exit; end else if ParamCompatibility=tcCompatible then begin Result:=tcCompatible; end; CurParamNode1:=CurParamNode1.NextBrother; CurParamNode2:=CurParamNode2.NextBrother; inc(i); end; Params.Flags:=OldFlags; end; function TFindDeclarationTool.GetParameterNode(Node: TCodeTreeNode ): TCodeTreeNode; begin {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF} Result:=Node; if Result<>nil then begin if (Result.Desc=ctnProperty) then Result:=Result.FirstChild else if Result.Desc in [ctnProcedure,ctnProcedureHead] then begin BuildSubTreeForProcHead(Result); if Result.Desc=ctnProcedure then Result:=Result.FirstChild; if Result.Desc=ctnProcedureHead then Result:=Result.FirstChild; end; end; end; function TFindDeclarationTool.GetFirstParameterNode(Node: TCodeTreeNode ): TCodeTreeNode; begin Result:=GetParameterNode(Node); if Result<>nil then Result:=Result.FirstChild; end; function TFindDeclarationTool.CheckSrcIdentifier( Params: TFindDeclarationParams; const FoundContext: TFindContext): TIdentifierFoundResult; // this is a TOnIdentifierFound function // if identifier found is a proc then it searches for the best overloaded proc var FirstParameterNode, StartContextNode: TCodeTreeNode; ParamCompatibility: TTypeCompatibility; OldInput: TFindDeclarationInput; CurCompatibilityList: TTypeCompatibilityList; CompListSize: integer; NewExprInputList: TExprTypeList; begin // the search has found an identifier with the right name {$IFDEF ShowFoundIdentifier} DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]', ' Ident=',GetIdentifier(Params.Identifier), ' FoundContext=',FoundContext.Node.DescAsString, ' Flags=[',FindDeclarationFlagsAsString(Params.Flags),']' ); {$ENDIF} if FoundContext.Node.Desc=ctnProcedure then begin // the found node is a proc // 1. the current identifier cache is blind for parameter lists // => proc identifiers can not be identified by the name alone // -> do not cache // 2. Even if there is only one proc. With different search flags, // different routes will be searched and then there can be another proc. // The only solution is to store the param expression list and all flags // in the cache. This is a ToDo Include(Params.Flags,fdfDoNotCache); Include(Params.NewFlags,fodDoNotCache); if (fdfIgnoreOverloadedProcs in Params.Flags) then begin // do not check for overloaded procs -> ident found Result:=ifrSuccess; exit; end; // Procs can be overloaded, that means there can be several procs with the // same name, but with different param lists. // The search must go on, and the most compatible proc is returned. if not Params.IdentifierTool.IsPCharInSrc(Params.Identifier) then begin // Params.Identifier is not in the source of the start tool // => impossible to check param list, because the context is unknown // -> identifier found {$IFDEF ShowProcSearch} DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]', ' Ident=',GetIdentifier(Params.Identifier), ' NO SOURCE to check params' ); {$ENDIF} Result:=ifrSuccess; exit; end; Result:=ifrProceedSearch; if (Params.FoundProc=nil) then begin // this is the first proc found // -> save it and proceed the search to find all overloadeded procs {$IF defined(ShowFoundIdentifier) or defined(ShowProcSearch)} DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]', ' Ident=',GetIdentifier(Params.Identifier), ' ',FoundContext.Tool.CleanPosToStr(FoundContext.Node.StartPos), ' FIRST PROC' ); {$ENDIF} Params.SetFirstFoundProc(FoundContext); exit; end; // -> check which one is more compatible // create the input expression list // (the expressions in the brackets are parsed and converted to types) if Params.FoundProc^.ExprInputList=nil then begin {$IF defined(ShowFoundIdentifier) or defined(ShowProcSearch)} DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]', ' Ident=',GetIdentifier(Params.Identifier), ' Creating Input Expression List ...' ); {$ENDIF} if Params.IdentifierTool.IsPCharInSrc(Params.Identifier) then begin Params.IdentifierTool.MoveCursorToCleanPos(Params.Identifier); StartContextNode:=Params.IdentifierTool.FindDeepestNodeAtPos( Params.IdentifierTool.CurPos.StartPos,true); if (StartContextNode<>nil) then begin if (StartContextNode.Desc in AllPascalStatements) then begin {$IFDEF ShowProcSearch} DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]', ' Ident=',GetIdentifier(Params.Identifier), ' Creating Input Expression List for statement ...' ); {$ENDIF} Params.Save(OldInput); Params.IdentifierTool.MoveCursorToCleanPos(Params.Identifier); Params.Flags:=fdfDefaultForExpressions+Params.Flags*fdfGlobals; Params.ContextNode:=StartContextNode; Params.OnIdentifierFound:=@Params.IdentifierTool.CheckSrcIdentifier; Params.IdentifierTool.ReadNextAtom; NewExprInputList:= Params.IdentifierTool.CreateParamExprListFromStatement( Params.IdentifierTool.CurPos.EndPos,Params); Params.Load(OldInput,true); FreeAndNil(Params.FoundProc^.ExprInputList); Params.FoundProc^.ExprInputList:=NewExprInputList; end else if (StartContextNode.Desc in [ctnProcedureHead,ctnProcedure]) then begin {$IFDEF ShowProcSearch} DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]', ' Ident=',GetIdentifier(Params.Identifier), ' Creating Input Expression List for proc node ...' ); {$ENDIF} NewExprInputList:= Params.IdentifierTool.CreateParamExprListFromProcNode( StartContextNode,Params); FreeAndNil(Params.FoundProc^.ExprInputList); Params.FoundProc^.ExprInputList:=NewExprInputList; end; end; end; if Params.FoundProc^.ExprInputList=nil then begin // create expression list without params Params.FoundProc^.ExprInputList:=TExprTypeList.Create; end; end; // create compatibility lists for params // (each parameter is checked for compatibility) CompListSize:=SizeOf(TTypeCompatibility) *Params.FoundProc^.ExprInputList.Count; if (CompListSize>0) and (Params.FoundProc^.ParamCompatibilityList=nil) then begin GetMem(Params.FoundProc^.ParamCompatibilityList,CompListSize); //DebugLn(['TFindDeclarationTool.CheckSrcIdentifier FoundProc=',dbgs(Params.FoundProc),' New ParamCompatibilityList=',dbgs(Params.FoundProc^.ParamCompatibilityList),' CompListSize=',CompListSize]); end else begin //DebugLn(['TFindDeclarationTool.CheckSrcIdentifier FoundProc=',dbgs(Params.FoundProc),' Old ParamCompatibilityList=',dbgs(Params.FoundProc^.ParamCompatibilityList),' CompListSize=',CompListSize]); end; // check the first found proc for compatibility // (compare the expression list with the proc param list) if not Params.FoundProc^.CacheValid then begin {$IF defined(ShowFoundIdentifier) or defined(ShowProcSearch)} DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]', ' Ident=',GetIdentifier(Params.Identifier), ' Check the first found proc for compatibility ...' ); {$ENDIF} FirstParameterNode:=Params.FoundProc^.Context.Tool.GetFirstParameterNode( Params.FoundProc^.Context.Node); ParamCompatibility:= Params.FoundProc^.Context.Tool.IsParamExprListCompatibleToNodeList( FirstParameterNode, Params.FoundProc^.ExprInputList, fdfIgnoreMissingParams in Params.Flags, Params,Params.FoundProc^.ParamCompatibilityList); Params.FoundProc^.ProcCompatibility:=ParamCompatibility; Params.FoundProc^.CacheValid:=true; if ParamCompatibility=tcExact then begin Params.SetResult(Params.FoundProc^.Context.Tool, Params.FoundProc^.Context.Node.FirstChild); end; end; if Params.FoundProc^.ProcCompatibility=tcExact then begin {$IF defined(ShowFoundIdentifier) or defined(ShowProcSearch)} DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]', ' Ident=',GetIdentifier(Params.Identifier), ' First Proc ParamCompatibility=',TypeCompatibilityNames[Params.FoundProc^.ProcCompatibility] ); {$ENDIF} // the first proc fits exactly -> stop the search Result:=ifrSuccess; exit; end; // check the current proc for compatibility // (compare the expression list with the proc param list) {$IF defined(ShowFoundIdentifier) or defined(ShowProcSearch)} DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]', ' Ident=',GetIdentifier(Params.Identifier), ' Check the current found proc for compatibility ...' ); {$ENDIF} if CompListSize>0 then begin GetMem(CurCompatibilityList,CompListSize); //DebugLn(['TFindDeclarationTool.CheckSrcIdentifier create temp CurCompatibilityList=',dbgs(CurCompatibilityList),' CompListSize=',CompListSize]); end else begin CurCompatibilityList:=nil; end; try FirstParameterNode:= FoundContext.Tool.GetFirstParameterNode(FoundContext.Node); ParamCompatibility:= FoundContext.Tool.IsParamExprListCompatibleToNodeList( FirstParameterNode, Params.FoundProc^.ExprInputList, fdfIgnoreMissingParams in Params.Flags, Params,CurCompatibilityList); {$IF defined(ShowFoundIdentifier) or defined(ShowProcSearch)} DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]', ' Ident=',GetIdentifier(Params.Identifier), ' Current Proc ParamCompatibility=',TypeCompatibilityNames[ParamCompatibility] ); {$ENDIF} if ParamCompatibility=tcExact then begin // the current proc fits exactly -> stop the search Params.ChangeFoundProc(FoundContext,ParamCompatibility, CurCompatibilityList); CurCompatibilityList:=nil; // set to nil, so that it will not be freed Params.SetResult(FoundContext.Tool,FoundContext.Node.FirstChild); Result:=ifrSuccess; end else if ParamCompatibility=tcCompatible then begin // the proc fits not exactly, but is compatible if (Params.FoundProc^.ProcCompatibility=tcInCompatible) or CompatibilityList1IsBetter(CurCompatibilityList, Params.FoundProc^.ParamCompatibilityList, Params.FoundProc^.ExprInputList.Count) then begin // the new proc fits better Params.ChangeFoundProc(FoundContext,ParamCompatibility, CurCompatibilityList); CurCompatibilityList:=nil; // set to nil, so that it will not be freed end; end; finally // end overloaded proc search if CurCompatibilityList<>nil then begin //DebugLn(['TFindDeclarationTool.CheckSrcIdentifier free CurCompatibilityList=',dbgs(CurCompatibilityList)]); FreeMem(CurCompatibilityList); end; end; end else begin Result:=ifrSuccess; end; end; function TFindDeclarationTool.DoOnIdentifierFound( Params: TFindDeclarationParams; FoundNode: TCodeTreeNode): TIdentifierFoundResult; // this internal function is called, whenever an identifier is found var IsTopLvlIdent: boolean; begin {$IFDEF CheckNodeTool}CheckNodeTool(FoundNode);{$ENDIF} IsTopLvlIdent:=(fdfTopLvlResolving in Params.Flags); if Assigned(Params.OnIdentifierFound) then Result:=Params.OnIdentifierFound(Params,CreateFindContext(Self,FoundNode)) else Result:=ifrSuccess; if (Result=ifrSuccess) and IsTopLvlIdent and Assigned(Params.OnTopLvlIdentifierFound) then Params.OnTopLvlIdentifierFound(Params,CreateFindContext(Self,FoundNode)); end; function TFindDeclarationTool.IsCompatible(TargetNode: TCodeTreeNode; const ExpressionType: TExpressionType; Params: TFindDeclarationParams): TTypeCompatibility; var TargetContext: TFindContext; OldInput: TFindDeclarationInput; NodeExprType: TExpressionType; begin {$IFDEF CheckNodeTool}CheckNodeTool(TargetNode);{$ENDIF} {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.IsCompatible] A Node=',TargetNode.DescAsString, ' ExpressionType=',ExpressionTypeDescNames[ExpressionType.Desc]); {$ENDIF} Result:=tcIncompatible; // find base type of node OldInput.Flags:=Params.Flags; Include(Params.Flags,fdfExceptionOnNotFound); TargetContext:=FindBaseTypeOfNode(Params,TargetNode); Params.Flags:=OldInput.Flags; // compare node base type and ExpressionType if (ExpressionType.Context.Node<>nil) and (ExpressionType.Context.Node=TargetContext.Node) then begin // same base type Result:=tcExact; end else if (TargetContext.Node.Desc=ctnGenericParameter) or ((ExpressionType.Desc=xtContext) and (ExpressionType.Context.Node.Desc=ctnGenericParameter)) then begin // generic type is always preferred Result:=tcExact; end else if (TargetContext.Node.Desc=ctnSetType) then begin {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.IsCompatible] TargetContext.Node.Desc=ctnSetType', ' "',copy(TargetContext.Tool.Src,TargetContext.Node.Parent.StartPos,20),'"'); {$ENDIF} if (ExpressionType.Desc=xtConstSet) then begin // both are sets, compare type of sets if (ExpressionType.SubDesc<>xtNone) then begin // ToDo: check if enums of expression fits into enums of target // ToDo: ppu, ppw, dcu Result:=tcCompatible; end else // the empty set is compatible to all kinds of sets Result:=tcExact; end else begin end; end else begin NodeExprType:=CleanExpressionType; NodeExprType.Desc:=xtContext; NodeExprType.Context:=CreateFindContext(Self,TargetNode); Result:=IsCompatible(NodeExprType,ExpressionType,Params); end; {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.IsCompatible] END', ' BaseNode=',TargetContext.Node.DescAsString, ' ExpressionType=',ExpressionTypeDescNames[ExpressionType.Desc], ' Result=',TypeCompatibilityNames[Result] ); {$ENDIF} end; function TFindDeclarationTool.IsCompatible(TargetType, ExpressionType: TExpressionType; Params: TFindDeclarationParams ): TTypeCompatibility; begin if TargetType.Desc=xtContext then begin if TargetType.Context.Node.Desc=ctnGenericParameter then exit(tcExact); TargetType:=TargetType.Context.Tool.ConvertNodeToExpressionType( TargetType.Context.Node,Params); end; if ExpressionType.Desc=xtContext then begin if ExpressionType.Context.Node.Desc=ctnGenericParameter then exit(tcExact); ExpressionType:=ExpressionType.Context.Tool.ConvertNodeToExpressionType( ExpressionType.Context.Node,Params); end; Result:=IsBaseCompatible(TargetType,ExpressionType,Params); end; function TFindDeclarationTool.GetCurrentAtomType: TVariableAtomType; var Node: TCodeTreeNode; begin if (CurPos.StartPos=CurPos.EndPos) then Result:=vatSpace else if (CurPos.StartPos>SrcLen) then Result:=vatNone else if IsIdentStartChar[Src[CurPos.StartPos]] then begin if WordIsPredefinedIdentifier.DoItCaseInsensitive(Src,CurPos.StartPos, CurPos.EndPos-CurPos.StartPos) then Result:=vatPreDefIdentifier else if UpAtomIs('INHERITED') then Result:=vatINHERITED else if UpAtomIs('AS') then Result:=vatAS else if WordIsKeyWord.DoItCaseInsensitive(Src,CurPos.StartPos, CurPos.EndPos-CurPos.StartPos) then Result:=vatKeyWord else if UpAtomIs('PROPERTY') then begin Node:=FindDeepestNodeAtPos(CurPos.StartPos,false); if (Node<>nil) and (Node.Desc=ctnProperty) then Result:=vatKeyword else Result:=vatIdentifier; end else Result:=vatIdentifier; end else if (CurPos.StartPos>=1) and (CurPos.StartPos<=SrcLen) and (CurPos.StartPos=CurPos.EndPos-1) then begin case Src[CurPos.StartPos] of '.': Result:=vatPoint; '^': Result:=vatUp; '(': Result:=vatRoundBracketOpen; ')': Result:=vatRoundBracketClose; '[': Result:=vatEdgedBracketOpen; ']': Result:=vatEdgedBracketClose; '@': Result:=vatAddrOp; else Result:=vatNone; end; end else Result:=vatNone; end; function TFindDeclarationTool.CreateParamExprListFromStatement( StartPos: integer; Params: TFindDeclarationParams): TExprTypeList; var ExprType: TExpressionType; BracketClose: char; ExprStartPos, ExprEndPos: integer; CurIgnoreErrorAfterPos: Integer; OldFlags: TFindDeclarationFlags; ok: Boolean; procedure RaiseBracketNotFound; begin RaiseExceptionFmt(ctsStrExpectedButAtomFound,[BracketClose,GetAtom]); end; begin {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.CreateParamExprListFromStatement] ', '"',copy(Src,StartPos,40),'" Context=',Params.ContextNode.DescAsString); {$ENDIF} Result:=TExprTypeList.Create; ok:=false; try MoveCursorToCleanPos(StartPos); ReadNextAtom; // reads first atom after proc name if AtomIsChar('(') then BracketClose:=')' else if AtomIsChar('[') then BracketClose:=']' else BracketClose:=#0; if IgnoreErrorAfterValid then CurIgnoreErrorAfterPos:=IgnoreErrorAfterCleanedPos else CurIgnoreErrorAfterPos:=-1; OldFlags:=Params.Flags; if BracketClose<>#0 then begin // read parameter list ReadNextAtom; if not AtomIsChar(BracketClose) then begin // read all expressions while true do begin ExprStartPos:=CurPos.StartPos; // read til comma or bracket close repeat if CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen] then begin ReadTilBracketClose(true); end; ReadNextAtom; if (CurPos.StartPos>SrcLen) or (CurPos.Flag in [cafRoundBracketClose,cafEdgedBracketClose,cafComma]) then break; until false; ExprEndPos:=CurPos.StartPos; // find expression type if (CurIgnoreErrorAfterPos>=ExprStartPos) then Params.Flags:=Params.Flags-[fdfExceptionOnNotFound]; //DebugLn('TFindDeclarationTool.CreateParamExprListFromStatement CurIgnoreErrorAfterPos=',dbgs(CurIgnoreErrorAfterPos),' ExprStartPos=',dbgs(ExprStartPos)); ExprType:=FindExpressionResultType(Params,ExprStartPos,ExprEndPos); // add expression type to list Result.Add(ExprType); MoveCursorToCleanPos(ExprEndPos); ReadNextAtom; if AtomIsChar(BracketClose) then break; if not AtomIsChar(',') then RaiseBracketNotFound; ReadNextAtom; end; end; end; Params.Flags:=OldFlags; {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.CreateParamExprListFromStatement] END ', 'ParamCount=',dbgs(Result.Count),' "',copy(Src,StartPos,40),'"'); DebugLn(' ExprList=[',Result.AsString,']'); {$ENDIF} Ok:=true; finally if not Ok then Result.Free; end; end; function TFindDeclarationTool.CreateParamExprListFromProcNode( ProcNode: TCodeTreeNode; Params: TFindDeclarationParams): TExprTypeList; var ExprType: TExpressionType; ParamNode: TCodeTreeNode; begin {$IFDEF CheckNodeTool}CheckNodeTool(ProcNode);{$ENDIF} {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.CreateParamExprListFromProcNode] ', '"',copy(Src,ProcNode.StartPos,40),'" Context=',ProcNode.DescAsString); {$ENDIF} Result:=TExprTypeList.Create; ParamNode:=GetFirstParameterNode(ProcNode); while ParamNode<>nil do begin // find expression type ExprType:=ConvertNodeToExpressionType(ParamNode,Params); // add expression type to list Result.Add(ExprType); ParamNode:=ParamNode.NextBrother; end; {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.CreateParamExprListFromProcNode] END ', 'ParamCount=',dbgs(Result.Count),' "',copy(Src,ProcNode.StartPos,40),'"'); DebugLn(' ExprList=[',Result.AsString,']'); {$ENDIF} end; function TFindDeclarationTool.CompatibilityList1IsBetter( List1, List2: TTypeCompatibilityList; ListCount: integer): boolean; // List1 and List2 should only contain tcCompatible and tcExact values var i: integer; begin // search first difference, start at end i:=ListCount-1; while (i>=0) and (List1[i]=List2[i]) do dec(i); // List1 is better, if first difference is better for List1 Result:=(i>=0) and (List1[i]=tcExact); {$IFDEF ShowFoundIdentifier} DebugLn('[TFindDeclarationTool.CompatibilityList1IsBetter] END i=',dbgs(i)); {$ENDIF} end; function TFindDeclarationTool.ContextIsDescendOf(const DescendContext, AncestorContext: TFindContext; Params: TFindDeclarationParams): boolean; procedure RaiseInternalError; begin RaiseException('[TFindDeclarationTool.ContextIsDescendOf] ' +' internal error: DescendContext.Desc<>ctnClass'); end; var CurContext: TFindContext; OldInput: TFindDeclarationInput; begin if not (DescendContext.Node.Desc in AllClasses) then RaiseInternalError; {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.ContextIsDescendOf] ', ' DescendContext="',copy(DescendContext.Tool.Src,DescendContext.Node.Parent.StartPos,15),'"'); {$ENDIF} CurContext:=DescendContext; Params.Save(OldInput); repeat Result:=CurContext.Tool.FindAncestorOfClass(CurContext.Node,Params,true); if Result then begin CurContext:=CreateFindContext(Params); {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.ContextIsDescendOf] B ', ' CurContext="',copy(CurContext.Tool.Src,CurContext.Node.Parent.StartPos,15),'"'); {$ENDIF} Result:=FindContextAreEqual(CurContext,AncestorContext); if Result then exit; end else break; until false; Result:=false; end; function TFindDeclarationTool.IsBaseCompatible(const TargetType, ExpressionType: TExpressionType; Params: TFindDeclarationParams ): TTypeCompatibility; // test if ExpressionType can be assigned to TargetType // both expression types must be base types var TargetNode, ExprNode: TCodeTreeNode; begin {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.IsBaseCompatible] B ', ' TargetType=',ExprTypeToString(TargetType), ' ExpressionType=',ExprTypeToString(ExpressionType)); {$ENDIF} Result:=tcIncompatible; if (TargetType.Desc=xtContext) and (TargetType.Context.Node.Desc=ctnGenericParameter) then exit(tcExact); if (ExpressionType.Desc=xtContext) and (ExpressionType.Context.Node.Desc=ctnGenericParameter) then exit(tcExact); if (TargetType.Desc=ExpressionType.Desc) then begin case TargetType.Desc of xtNone: ; xtContext: begin TargetNode:=TargetType.Context.Node; ExprNode:=ExpressionType.Context.Node; {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.IsBaseCompatible] C ', ' TargetContext="',copy(TargetType.Context.Tool.Src,TargetType.Context.Node.StartPos,20),'"', ' ExpressionContext="',copy(ExpressionType.Context.Tool.Src,ExpressionType.Context.Node.StartPos,20),'"' ); {$ENDIF} if TargetNode=ExprNode then Result:=tcExact else if ExprNode.Desc=TargetNode.Desc then begin // same context type case ExprNode.Desc of ctnClass, ctnClassInterface, ctnDispinterface, ctnObject, ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass: // check, if ExpressionType.Context is descend of TargetContext if ContextIsDescendOf(ExpressionType.Context, TargetType.Context,Params) then Result:=tcCompatible; ctnRangedArrayType,ctnOpenArrayType: // ToDo: check range and type of arrayfields begin Result:=tcCompatible; end; end; end else begin // different context type end; end; else Result:=tcExact; end; end else if ((TargetType.Desc=xtPointer) and (ExpressionType.Desc=xtContext) and (ExpressionType.Context.Node.Desc in AllClasses)) then begin // assigning a class to a pointer Result:=tcExact; end else begin // check, if ExpressionType can be auto converted into TargetType if ((TargetType.Desc in xtAllRealTypes) and (ExpressionType.Desc in xtAllRealConvertibles)) or ((TargetType.Desc in xtAllStringTypes) and (ExpressionType.Desc in xtAllStringConvertibles)) or ((TargetType.Desc in xtAllWideStringTypes) and (ExpressionType.Desc in xtAllWideStringCompatibleTypes)) or ((TargetType.Desc in xtAllIntegerTypes) and (ExpressionType.Desc in xtAllIntegerConvertibles)) or ((TargetType.Desc in xtAllBooleanTypes) and (ExpressionType.Desc in xtAllBooleanConvertibles)) or ((TargetType.Desc in xtAllPointerTypes) and (ExpressionType.Desc in xtAllPointerConvertibles)) then Result:=tcCompatible else if (TargetType.Desc=xtContext) then begin TargetNode:=TargetType.Context.Node; if ((TargetNode.Desc in (AllClasses+[ctnProcedure])) and (ExpressionType.Desc=xtNil)) or ((TargetNode.Desc in [ctnOpenArrayType,ctnRangedArrayType]) and (TargetNode.LastChild<>nil) and (TargetNode.LastChild.Desc=ctnOfConstType) and (ExpressionType.Desc=xtConstSet)) then Result:=tcCompatible end else if (ExpressionType.Desc=xtContext) then begin ExprNode:=ExpressionType.Context.Node; if (TargetType.Desc=xtFile) and (ExprNode.Desc=ctnFileType) then Result:=tcCompatible end; end; {$IFDEF ShowExprEval} DebugLn('[TFindDeclarationTool.IsBaseCompatible] END ', ' TargetType=',ExpressionTypeDescNames[TargetType.Desc], ' ExpressionType=',ExpressionTypeDescNames[ExpressionType.Desc], ' Result=',TypeCompatibilityNames[Result] ); {$ENDIF} end; function TFindDeclarationTool.CheckParameterSyntax(CursorNode: TCodeTreeNode; CleanCursorPos: integer; out ParameterAtom, ProcNameAtom: TAtomPosition; out ParameterIndex: integer): boolean; // check for Identifier(expr,expr,...,expr,VarName // or Identifier[expr,expr,...,expr,VarName // ParameterIndex is 0 based {off $DEFINE VerboseCPS} procedure RaiseBracketNotOpened; begin if CurPos.Flag=cafRoundBracketClose then SaveRaiseExceptionFmt(ctsBracketNotFound,['(']) else SaveRaiseExceptionFmt(ctsBracketNotFound,['[']); end; function CheckIdentifierAndParameterList: boolean; forward; function CheckBrackets: boolean; var BracketAtom: TAtomPosition; begin BracketAtom:=CurPos; {$IFDEF VerboseCPS}DebugLn('CheckBrackets "',GetAtom,'" BracketAtom=',dbgs(BracketAtom));{$ENDIF} repeat ReadNextAtom; if CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen] then begin if (LastAtoms.GetValueAt(0).Flag=cafWord) then begin {$IFDEF VerboseCPS}DebugLn('CheckBrackets check word+bracket open');{$ENDIF} UndoReadNextAtom; if CheckIdentifierAndParameterList() then exit(true); end else begin {$IFDEF VerboseCPS}DebugLn('CheckBrackets check bracket open');{$ENDIF} if CheckBrackets() then exit(true); end; end else if CurPos.Flag in [cafRoundBracketClose,cafEdgedBracketClose] then begin if (BracketAtom.Flag=cafRoundBracketOpen) =(CurPos.Flag=cafRoundBracketClose) then begin // closing bracket found, but the variable was not in them {$IFDEF VerboseCPS}DebugLn('CheckBrackets bracket closed');{$ENDIF} exit(false); end else begin // invalid closing bracket found RaiseBracketNotOpened; end; end; until (CurPos.EndPos>CleanCursorPos); Result:=false; end; function CheckIdentifierAndParameterList: boolean; var BracketAtom: TAtomPosition; CurProcNameAtom: TAtomPosition; CurParameterIndex: Integer; ParameterStart: integer; begin Result:=false; CurProcNameAtom:=CurPos; CurParameterIndex:=0; {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList START "',GetAtom,'" ',dbgs(CurProcNameAtom));{$ENDIF} ReadNextAtom; if CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen] then begin BracketAtom:=CurPos; ParameterStart:=CurPos.EndPos; {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList Bracket="',GetAtom,'"');{$ENDIF} repeat ReadNextAtom; {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList Atom="',GetAtom,'"');{$ENDIF} if (CurPos.EndPos>CleanCursorPos) or ((CurPos.EndPos=CleanCursorPos) and (CurPos.Flag=cafWord)) then begin // parameter found => search parameter expression bounds e.g. ', parameter ,' // important: this function should work, even the code behind // CleanCursorPos is buggy {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList Parameter found, search range ...');{$ENDIF} ProcNameAtom:=CurProcNameAtom; ParameterIndex:=CurParameterIndex; ParameterAtom.StartPos:=ParameterStart; ParameterAtom.EndPos:=ParameterStart; MoveCursorToCleanPos(ParameterStart); repeat ReadNextAtom; {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList parameter atom "',GetAtom,'"');{$ENDIF} if (CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen]) then ReadTilBracketClose(false) else if (CurPos.Flag in [cafNone,cafComma,cafSemicolon,cafEnd, cafRoundBracketClose,cafEdgedBracketClose]) or ((CurPos.Flag=cafWord) and (LastAtoms.GetValueAt(0).Flag=cafWord) and (not LastUpAtomIs(0,'INHERITED'))) then begin // end of parameter expression found {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList end of parameter found');{$ENDIF} exit(true); end else begin // atom belongs to the parameter expression if ParameterAtom.StartPos=ParameterStart then ParameterAtom.StartPos:=CurPos.StartPos; ParameterAtom.EndPos:=CurPos.EndPos; end; until false; end; if (CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen]) then begin if (LastAtoms.GetValueAt(0).Flag=cafWord) then begin {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList check word+bracket open');{$ENDIF} UndoReadNextAtom; if CheckIdentifierAndParameterList() then exit(true); end else begin {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList check bracket open');{$ENDIF} if CheckBrackets then exit(true); end; end else if CurPos.Flag in [cafRoundBracketClose,cafEdgedBracketClose] then begin {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList check bracket close');{$ENDIF} if (BracketAtom.Flag=cafRoundBracketOpen) =(CurPos.Flag=cafRoundBracketClose) then begin // parameter list ended in front of Variable => continue search {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList parameter list ended in front of cursor');{$ENDIF} exit; end else begin // invalid closing bracket found RaiseBracketNotOpened; end; end; // finally after checking the expression: count commas if CurPos.Flag=cafComma then begin ParameterStart:=CurPos.EndPos; inc(CurParameterIndex); end; {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList After parsing atom. atom="',GetAtom,'"');{$ENDIF} until (CurPos.EndPos>CleanCursorPos); end; end; begin {$IFDEF CheckNodeTool}CheckNodeTool(CursorNode);{$ENDIF} Result:=false; ParameterAtom:=CleanAtomPosition; ProcNameAtom:=CleanAtomPosition; ParameterIndex:=0; //DebugLn('TFindDeclarationTool.CheckParameterSyntax START'); // read code in front to find ProcName and check the syntax MoveCursorToNodeStart(CursorNode); repeat ReadNextAtom; {$IFDEF VerboseCPS}DebugLn('TCodeCompletionCodeTool.CheckParameterSyntax ',GetAtom,' ',dbgs(CurPos.EndPos),'<',dbgs(CleanCursorPos));{$ENDIF} if CurPos.EndPos>CleanCursorPos then exit; if (CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen]) and (LastAtoms.GetValueAt(0).Flag=cafWord) then begin UndoReadNextAtom; if CheckIdentifierAndParameterList then exit(true); end; until false; Result:=true; end; function TFindDeclarationTool.FindNthParameterNode(Node: TCodeTreeNode; ParameterIndex: integer): TCodeTreeNode; var ProcNode, FunctionNode: TCodeTreeNode; ProcHeadNode: TCodeTreeNode; ParameterNode: TCodeTreeNode; i: Integer; begin {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF} Result:=nil; if Node=nil then exit; if Node.Desc in [ctnProcedure] then begin ProcNode:=Node; //DebugLn(' FindNthParameterNode ProcNode="',copy(Params.NewCodeTool.Src,ProcNode.StartPos,ProcNode.EndPos-ProcNode.StartPos),'"'); FunctionNode:=nil; BuildSubTreeForProcHead(ProcNode,FunctionNode); // find procedure head ProcHeadNode:=ProcNode.FirstChild; if (ProcHeadNode=nil) or (ProcHeadNode.Desc<>ctnProcedureHead) then begin DebugLn(' FindNthParameterNode Procedure has no parameter list'); exit; end; // find parameter list ParameterNode:=ProcHeadNode.FirstChild; if (ParameterNode=nil) or (ParameterNode.Desc<>ctnParameterList) then begin DebugLn(' FindNthParameterNode Procedure has no parameter list'); exit; end; // find parameter ParameterNode:=ParameterNode.FirstChild; i:=0; while (inil) do begin //DebugLn(' FindNthParameterNode ',ParameterNode.DescAsString); ParameterNode:=ParameterNode.NextBrother; inc(i); end; Result:=ParameterNode; end; end; function TFindDeclarationTool.OpenCodeToolForUnit(UnitNameAtom, UnitInFileAtom: TAtomPosition; ExceptionOnNotFound: boolean): TFindDeclarationTool; begin // open the unit Result:=FindCodeToolForUsedUnit(UnitNameAtom,UnitInFileAtom, ExceptionOnNotFound); if Result=nil then begin if ExceptionOnNotFound then begin MoveCursorToCleanPos(UnitNameAtom.StartPos); RaiseExceptionInstance( ECodeToolUnitNotFound.Create(Self, Format(ctsUnitNotFound,[GetAtom(UnitNameAtom)]), GetAtom(UnitNameAtom))); end; end else if Result=Self then begin MoveCursorToCleanPos(UnitNameAtom.StartPos); RaiseExceptionFmt(ctsIllegalCircleInUsedUnits,[GetAtom(UnitNameAtom)]); end; end; function TFindDeclarationTool.CheckDirectoryCache: boolean; begin if FDirectoryCache<>nil then exit(true); if Assigned(OnGetDirectoryCache) then FDirectoryCache:=OnGetDirectoryCache(ExtractFilePath(MainFilename)); Result:=FDirectoryCache<>nil; end; procedure TFindDeclarationTool.DoDeleteNodes; begin ClearNodeCaches(true); if FInterfaceIdentifierCache<>nil then begin FInterfaceIdentifierCache.Clear; FInterfaceIdentifierCache.Complete:=false; end; inherited DoDeleteNodes; end; function TFindDeclarationTool.NodeCacheGlobalWriteLockStepDidNotChange: boolean; // checks if a node cache check is in the same GlobalWriteLockStep // returns true if _no_ update is needed // returns false, if further checks are needed var GlobalWriteLockIsSet: boolean; GlobalWriteLockStep: integer; begin Result:=false; if Assigned(OnGetGlobalWriteLockInfo) then begin OnGetGlobalWriteLockInfo(GlobalWriteLockIsSet,GlobalWriteLockStep); if GlobalWriteLockIsSet then begin // The global write lock is set. That means, input variables and code // are frozen for all codetools and scanners, and therefore also for all // node caches if (FLastNodeCachesGlobalWriteLockStep=GlobalWriteLockStep) then begin // source and values did not change since last NodeCache check Result:=true; end else begin // this is the first check in this GlobalWriteLockStep FLastNodeCachesGlobalWriteLockStep:=GlobalWriteLockStep; // proceed normally ... end; end; end; {$IFDEF ShowCacheDependencies} DebugLn('[TFindDeclarationTool.NodeCacheGlobalWriteLockStepDidNotChange] Result=', DbgS(Result),' ',MainFilename); {$ENDIF} end; function TFindDeclarationTool.CheckDependsOnNodeCaches (CheckedTools: TAVLTree = nil): boolean; var ANode: TAVLTreeNode; ATool: TFindDeclarationTool; FreeCheckedTools: Boolean; begin Result:=false; //debugln(['TFindDeclarationTool.CheckDependsOnNodeCaches ',MainFilename,' FDependsOnCodeTools=',FDependsOnCodeTools]); if (FDependsOnCodeTools=nil) or FCheckingNodeCacheDependencies or NodeCacheGlobalWriteLockStepDidNotChange then exit; if (CheckedTools<>nil) and (CheckedTools.Find(Self)<>nil) then exit; {$IFDEF ShowCacheDependencies} DebugLn(['[TFindDeclarationTool.CheckDependsOnNodeCaches] START ',MainFilename,' ',FDependsOnCodeTools.Count]); {$ENDIF} FCheckingNodeCacheDependencies:=true; FreeCheckedTools:=false; if CheckedTools=nil then begin FreeCheckedTools:=true; CheckedTools:=TAVLTree.Create; end; try CheckedTools.Add(Self); ANode:=FDependsOnCodeTools.FindLowest; while ANode<>nil do begin ATool:=TFindDeclarationTool(ANode.Data); Result:=ATool.UpdateNeeded(true) or ATool.CheckDependsOnNodeCaches(CheckedTools); if Result then exit; ANode:=FDependsOnCodeTools.FindSuccessor(ANode); end; Result:=false; finally {$IFDEF ShowCacheDependencies} DebugLn('[TFindDeclarationTool.CheckDependsOnNodeCaches] Result=', DbgS(Result),' ',MainFilename); {$ENDIF} FCheckingNodeCacheDependencies:=false; if FreeCheckedTools then FreeAndNil(CheckedTools); if Result then ClearNodeCaches(true); end; end; destructor TFindDeclarationTool.Destroy; begin FInterfaceIdentifierCache.Free; FInterfaceIdentifierCache:=nil; FDependsOnCodeTools.Free; FDependsOnCodeTools:=nil; FDependentCodeTools.Free; FDependentCodeTools:=nil; if FDirectoryCache<>nil then begin FDirectoryCache.Release; FDirectoryCache:=nil; end; inherited Destroy; end; procedure TFindDeclarationTool.ClearNodeCaches(Force: boolean); var NodeCache: TCodeTreeNodeCache; BaseTypeCache: TBaseTypeCache; begin // check if there is something in cache to delete if (FFirstNodeCache=nil) and (FFirstBaseTypeCache=nil) and (FRootNodeCache=nil) and ((FDependentCodeTools=nil) or (FDependentCodeTools.Count=0)) and ((FDependsOnCodeTools=nil) or (FDependsOnCodeTools.Count=0)) then exit; {$IFDEF ShowCacheDependencies} DebugLn('[TFindDeclarationTool.ClearNodeCaches] Force=', DbgS(Force),' ',MainFilename); {$ENDIF} // quick check: check if in the same GlobalWriteLockStep if (not Force) and NodeCacheGlobalWriteLockStepDidNotChange then exit; // clear node caches while FFirstNodeCache<>nil do begin NodeCache:=FFirstNodeCache; FFirstNodeCache:=NodeCache.Next; NodeCacheMemManager.DisposeNodeCache(NodeCache); end; while FFirstBaseTypeCache<>nil do begin BaseTypeCache:=FFirstBaseTypeCache; FFirstBaseTypeCache:=BaseTypeCache.Next; BaseTypeCacheMemManager.DisposeBaseTypeCache(BaseTypeCache); end; if FRootNodeCache<>nil then begin NodeCacheMemManager.DisposeNodeCache(FRootNodeCache); FRootNodeCache:=nil; end; // clear dependent codetools ClearDependentNodeCaches; ClearDependsOnToolRelationships; end; procedure TFindDeclarationTool.ClearDependentNodeCaches; var ANode: TAVLTreeNode; DependentTool: TFindDeclarationTool; begin if (FDependentCodeTools=nil) or FClearingDependentNodeCaches then exit; FClearingDependentNodeCaches:=true; {$IFDEF ShowCacheDependencies} DebugLn('[TFindDeclarationTool.ClearDependentNodeCaches] ',MainFilename); {$ENDIF} try ANode:=FDependentCodeTools.FindLowest; while ANode<>nil do begin DependentTool:=TFindDeclarationTool(ANode.Data); DependentTool.ClearNodeCaches(true); ANode:=FDependentCodeTools.FindSuccessor(ANode); end; FDependentCodeTools.Clear; finally FClearingDependentNodeCaches:=false; end; end; procedure TFindDeclarationTool.ClearDependsOnToolRelationships; var ANode: TAVLTreeNode; DependOnTool: TFindDeclarationTool; begin if FDependsOnCodeTools=nil then exit; {$IFDEF ShowCacheDependencies} DebugLn('[TFindDeclarationTool.ClearDependsOnToolRelationships] ',MainFilename); {$ENDIF} ANode:=FDependsOnCodeTools.FindLowest; while ANode<>nil do begin DependOnTool:=TFindDeclarationTool(ANode.Data); if not DependOnTool.FClearingDependentNodeCaches then DependOnTool.FDependentCodeTools.Remove(Self); ANode:=FDependsOnCodeTools.FindSuccessor(ANode); end; FDependsOnCodeTools.Clear; end; procedure TFindDeclarationTool.AddToolDependency( DependOnTool: TFindDeclarationTool); // build a relationship: this tool depends on DependOnTool {$IFDEF DebugAddToolDependency} var AVLNode: TAVLTreeNode; Tool: TFindDeclarationTool; {$ENDIF} begin {$IFDEF ShowCacheDependencies} DebugLn('[TFindDeclarationTool.AddToolDependency] "',MainFilename,'" depends on "',DependOnTool.MainFilename,'"'); {$ENDIF} if DependOnTool.FDependentCodeTools=nil then DependOnTool.FDependentCodeTools:=TAVLTree.Create; if DependOnTool.FDependentCodeTools.Find(Self)=nil then DependOnTool.FDependentCodeTools.Add(Self); if FDependsOnCodeTools=nil then FDependsOnCodeTools:=TAVLTree.Create; if FDependsOnCodeTools.Find(DependOnTool)=nil then begin {$IFDEF DebugAddToolDependency} AVLNode:=FDependsOnCodeTools.FindLowest; while AVLNode<>nil do begin Tool:=TFindDeclarationTool(AVLNode.Data); if CompareFilenames(ExtractFilename(Tool.MainFilename),ExtractFilename(DependOnTool.MainFilename))=0 then begin DebugLn(['TFindDeclarationTool.AddToolDependency inconsistency: ',Tool.MainFilename,' ',DependOnTool.MainFilename]); end; AVLNode:=FDependsOnCodeTools.FindSuccessor(AVLNode); end; {$ENDIF} FDependsOnCodeTools.Add(DependOnTool); end; end; procedure TFindDeclarationTool.ConsistencyCheck; var ANodeCache: TCodeTreeNodeCache; begin inherited ConsistencyCheck; if FInterfaceIdentifierCache<>nil then FInterfaceIdentifierCache.ConsistencyCheck; ANodeCache:=FFirstNodeCache; while ANodeCache<>nil do begin ANodeCache.ConsistencyCheck; ANodeCache:=ANodeCache.Next; end; if FDependentCodeTools<>nil then begin if FDependentCodeTools.ConsistencyCheck<>0 then raise Exception.Create(''); end; if FDependsOnCodeTools<>nil then begin if FDependsOnCodeTools.ConsistencyCheck<>0 then raise Exception.Create(''); end; end; procedure TFindDeclarationTool.CalcMemSize(Stats: TCTMemStats); var NodeCache: TCodeTreeNodeCache; TypeCache: TBaseTypeCache; m: PtrUInt; begin inherited CalcMemSize(Stats); if FInterfaceIdentifierCache<>nil then Stats.Add('TFindDeclarationTool.FInterfaceIdentifierCache', FInterfaceIdentifierCache.CalcMemSize); if FFirstNodeCache<>nil then begin m:=0; NodeCache:=FFirstNodeCache; while NodeCache<>nil do begin inc(m,NodeCache.CalcMemSize); NodeCache:=NodeCache.Next; end; Stats.Add('TFindDeclarationTool.NodeCache',m); end; if FFirstBaseTypeCache<>nil then begin m:=0; TypeCache:=FFirstBaseTypeCache; while TypeCache<>nil do begin inc(m,TypeCache.CalcMemSize); TypeCache:=TypeCache.Next; end; Stats.Add('TFindDeclarationTool.TypeCache',m); end; if FDependentCodeTools<>nil then Stats.Add('TFindDeclarationTool.FDependentCodeTools', FDependentCodeTools.Count*SizeOf(TAVLTreeNode)); if FDependsOnCodeTools<>nil then Stats.Add('TFindDeclarationTool.FDependsOnCodeTools', FDependsOnCodeTools.Count*SizeOf(TAVLTreeNode)); end; procedure TFindDeclarationTool.ValidateToolDependencies; begin //debugln(['TFindDeclarationTool.ValidateToolDependencies ',MainFilename]); inherited ValidateToolDependencies; CheckDependsOnNodeCaches; end; function TFindDeclarationTool.GetNodeCache(Node: TCodeTreeNode; CreateIfNotExists: boolean): TCodeTreeNodeCache; begin {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF} while (Node<>nil) and (not (Node.Desc in AllNodeCacheDescs)) do Node:=Node.Parent; if Node<>nil then begin if (Node.Cache=nil) and CreateIfNotExists then CreateNewNodeCache(Node); if (Node.Cache<>nil) and (Node.Cache is TCodeTreeNodeCache) then Result:=TCodeTreeNodeCache(Node.Cache) else Result:=nil; end else begin if (FRootNodeCache=nil) and CreateIfNotExists then FRootNodeCache:=CreateNewNodeCache(nil); Result:=FRootNodeCache; end; end; procedure TFindDeclarationTool.AddResultToNodeCaches( StartNode, EndNode: TCodeTreeNode; SearchedForward: boolean; Params: TFindDeclarationParams; SearchRangeFlags: TNodeCacheEntryFlags); var Node: TCodeTreeNode; CurNodeCache, LastNodeCache: TCodeTreeNodeCache; CleanStartPos, CleanEndPos: integer; NewNode: TCodeTreeNode; NewTool: TPascalParserTool; NewCleanPos: integer; {$IFDEF ShowNodeCache} BeVerbose: boolean; NodeOwner: TObject; function WriteSrcPos(t: TPascalParserTool; p: integer): string; begin Result:=StringToPascalConst(copy(t.Src,p-10,10)+'|'+copy(t.Src,p,15)+'"'); end; function NodeOwnerAsString(ANodeOwner: TObject): string; begin if ANodeOwner=nil then Result:='nil' else if ANodeOwner is TPascalParserTool then Result:=ExtractFileName(TPascalParserTool(ANodeOwner).MainFilename) else Result:='?'+ANodeOwner.ClassName+'?'; end; {$ENDIF} begin {$IFDEF CheckNodeTool}CheckNodeTool(StartNode);{$ENDIF} if StartNode=nil then exit; if Params.NewNode<>nil then begin // identifier found NewNode:=Params.NewNode; NewTool:=Params.NewCodeTool; NewCleanPos:=Params.NewCleanPos; end else begin // identifier not found NewNode:=nil; NewTool:=nil; NewCleanPos:=-1; end; // calculate search range if EndNode<>nil then begin if SearchedForward then begin CleanStartPos:=StartNode.StartPos; CleanEndPos:=EndNode.EndPos; end else begin CleanStartPos:=EndNode.StartPos; CleanEndPos:=StartNode.EndPos; end; end else begin // searched till start or end of source if not SearchedForward then begin CleanStartPos:=1; CleanEndPos:=StartNode.StartPos; end else begin CleanStartPos:=StartNode.StartPos; CleanEndPos:=SrcLen+1; end; end; {$IFDEF ShowNodeCache} beVerbose:=true; //CompareSrcIdentifiers(Params.Identifier,'InitDecompressor'); if beVerbose then begin DebugLn('(((((((((((((((((((((((((((=================='); DbgOut('TFindDeclarationTool.AddResultToNodeCaches ', ' Ident=',GetIdentifier(Params.Identifier)); DbgOut(' SearchedForward=',DbgS(SearchedForward)); DbgOut(' Flags=['); if ncefSearchedInParents in SearchRangeFlags then DbgOut('Parents'); if ncefSearchedInAncestors in SearchRangeFlags then DbgOut(',Ancestors'); DebugLn(']'); DbgOut(' StartNode=',StartNode.DescAsString, '('+DbgS(StartNode.StartPos),'-',DbgS(StartNode.EndPos)+')=', WriteSrcPos(Self,StartNode.StartPos)); NodeOwner:=FindOwnerOfCodeTreeNode(StartNode); if NodeOwner<>Self then DbgOut(' StartNodeOwner=',NodeOwnerAsString(NodeOwner)); DebugLn(''); if EndNode<>nil then DbgOut(' EndNode=',EndNode.DescAsString, '('+DbgS(EndNode.StartPos),'-',DbgS(EndNode.EndPos)+')=', WriteSrcPos(Self,EndNode.StartPos)) else DbgOut(' EndNode=nil'); NodeOwner:=FindOwnerOfCodeTreeNode(EndNode); if NodeOwner<>Self then DbgOut(' EndNodeOwner=',NodeOwnerAsString(NodeOwner)); DebugLn(''); DebugLn(' Self=',ExtractFileName(MainFilename)); if NewNode<>nil then begin DebugLn(' NewNode=',NewNode.DescAsString, '(',DbgS(NewNode.StartPos),'-',DbgS(NewNode.EndPos),')=', WriteSrcPos(NewTool,NewNode.StartPos), ' NewTool=',ExtractFileName(NewTool.MainFilename)); end else begin DebugLn(' NOT FOUND'); //RaiseCatchableException(''); end; DebugLn(' CleanStartPos=',DbgS(CleanStartPos),' ',WriteSrcPos(Self,CleanStartPos)); DebugLn(' CleanEndPos=',DbgS(CleanEndPos),' ',WriteSrcPos(Self,CleanEndPos)); end; {$ENDIF} LastNodeCache:=nil; // start with parent of deepest node and end parent of highest Node:=StartNode; if (EndNode<>nil) then begin if (EndNode.GetLevel>StartNode.GetLevel) then begin Node:=EndNode; EndNode:=StartNode.Parent; end else begin EndNode:=EndNode.Parent; end; end else EndNode:=StartNode.Parent; Node:=Node.Parent; while (Node<>nil) do begin if (Node.Desc in AllNodeCacheDescs) then begin if (Node.Cache=nil) then CreateNewNodeCache(Node); if (Node.Cache is TCodeTreeNodeCache) then begin CurNodeCache:=TCodeTreeNodeCache(Node.Cache); if LastNodeCache<>CurNodeCache then begin {$IFDEF ShowNodeCache} if BeVerbose then begin CurNodeCache.WriteDebugReport(' BEFORE NODECACHE REPORT: '); end; {$ENDIF} CurNodeCache.Add(Params.Identifier, CleanStartPos,CleanEndPos, NewNode,NewTool,NewCleanPos,SearchRangeFlags); {$IFDEF ShowNodeCache} if BeVerbose then begin CurNodeCache.WriteDebugReport(' AFTER NODECACHE REPORT: '); end; {$ENDIF} LastNodeCache:=CurNodeCache; end; end; end; Node:=Node.Parent; if (EndNode=Node) then break; end; {$IFDEF ShowNodeCache} if BeVerbose then begin DebugLn('=========================))))))))))))))))))))))))))))))))'); end; {$ENDIF} end; function TFindDeclarationTool.CreateNewNodeCache( Node: TCodeTreeNode): TCodeTreeNodeCache; begin {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF} Result:=NodeCacheMemManager.NewNodeCache(Node); Result.Next:=FFirstNodeCache; FFirstNodeCache:=Result; end; function TFindDeclarationTool.CreateNewBaseTypeCache(Node: TCodeTreeNode ): TBaseTypeCache; begin {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF} Result:=BaseTypeCacheMemManager.NewBaseTypeCache(Node); Result.Next:=FFirstBaseTypeCache; FFirstBaseTypeCache:=Result; end; procedure TFindDeclarationTool.CreateBaseTypeCaches( NodeStack: PCodeTreeNodeStack; const Result: TFindContext); var i: integer; Node: TCodeTreeNodeStackEntry; BaseTypeCache: TBaseTypeCache; begin {$IFDEF ShowBaseTypeCache} DbgOut('[TFindDeclarationTool.CreateBaseTypeCaches] ', ' StackPtr=',DbgS(NodeStack^.StackPtr)); DebugLn(' Self=',MainFilename); if Result.Node<>nil then DbgOut(' Result='+Result.Node.DescAsString, ' Start='+DbgS(Result.Node.StartPos), ' End='+DbgS(Result.Node.EndPos), ' "'+copy(Src,Result.Node.StartPos,15)+'" ',Result.Tool.MainFilename) else DbgOut(' Result=nil'); DebugLn(''); {$ENDIF} for i:=0 to (NodeStack^.StackPtr-1) do begin Node:=GetNodeStackEntry(NodeStack,i); if (Node.Cache=nil) and ((Result.Tool<>Self) or (Result.Node<>Node)) then begin {$IFDEF ShowBaseTypeCache} DebugLn(' i=',DbgS(i),' Node=',Node.DescAsString,' "',copy(Src,Node.StartPos,15),'"'); {$ENDIF} BaseTypeCache:=CreateNewBaseTypeCache(Node); if BaseTypeCache<>nil then begin BaseTypeCache.NewNode:=Result.Node; BaseTypeCache.NewTool:=Result.Tool; end; end; end; end; function TFindDeclarationTool.GetExpressionTypeOfTypeIdentifier( Params: TFindDeclarationParams): TExpressionType; var OldFlags: TFindDeclarationFlags; begin OldFlags:=Params.Flags; if FindIdentifierInContext(Params) then begin Params.Flags:=OldFlags; Result:=Params.NewCodeTool.ConvertNodeToExpressionType(Params.NewNode,Params); end else begin // predefined identifier Params.Flags:=OldFlags; Result:=CleanExpressionType; Result.Desc:=PredefinedIdentToExprTypeDesc(Params.Identifier); end; end; function TFindDeclarationTool.FindTermTypeAsString(TermPos: TAtomPosition; CursorNode: TCodeTreeNode; Params: TFindDeclarationParams; out ExprType: TExpressionType): string; var EdgedBracketsStartPos: integer; SetNode: TCodeTreeNode; SetTool: TFindDeclarationTool; begin {$IFDEF CheckNodeTool}CheckNodeTool(CursorNode);{$ENDIF} Result:=''; if IsTermEdgedBracket(TermPos,EdgedBracketsStartPos) then begin MoveCursorToCleanPos(EdgedBracketsStartPos); ReadNextAtom; ReadNextAtom; if CurPos.Flag=cafWord then begin {$IFDEF ShowExprEval} debugln(['TFindDeclarationTool.FindTermTypeAsString [name check for enumeration type ...']); {$ENDIF} ExprType:=FindExpressionResultType(Params,EdgedBracketsStartPos+1,-1); {$IFDEF ShowExprEval} debugln(['TFindDeclarationTool.FindTermTypeAsString [name: ',ExprTypeToString(ExprType)]); {$ENDIF} if (ExprType.Desc=xtContext) and (ExprType.Context.Node.Desc=ctnEnumerationType) then begin SetTool:=ExprType.Context.Tool; SetNode:=SetTool.FindSetOfEnumerationType(ExprType.Context.Node); if SetNode<>nil then begin ExprType:=CleanExpressionType; ExprType.Desc:=xtContext; ExprType.SubDesc:=xtNone; ExprType.Context.Tool:=SetTool; ExprType.Context.Node:=SetNode; Result:=SetTool.ExtractDefinitionName(SetNode); exit; end; end; end; end; if IsTermNamedPointer(TermPos,ExprType) then begin // pointer type end else begin ExprType:=CleanExpressionType; Params.ContextNode:=CursorNode; Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors, fdfTopLvlResolving,fdfFunctionResult]; ExprType:=FindExpressionResultType(Params,TermPos.StartPos,TermPos.EndPos); end; Result:=FindExprTypeAsString(ExprType,TermPos.StartPos,Params); end; function TFindDeclarationTool.FindForInTypeAsString(TermPos: TAtomPosition; CursorNode: TCodeTreeNode; Params: TFindDeclarationParams; out ExprType: TExpressionType): string; procedure RaiseTermHasNoIterator; begin if TermPos.StartPos<1 then TermPos.StartPos:=1; MoveCursorToCleanPos(TermPos.StartPos); RaiseException('Can not find an enumerator for '''+TrimCodeSpace(GetAtom(TermPos))+''''); end; var TermExprType: TExpressionType; OperatorExprType: TExpressionType; begin ExprType:=CleanExpressionType; TermExprType:=CleanExpressionType; Params.ContextNode:=CursorNode; Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors, fdfTopLvlResolving,fdfFunctionResult]; TermExprType:=FindExpressionResultType(Params,TermPos.StartPos,TermPos.EndPos); {$IFDEF ShowExprEval} DebugLn('TFindDeclarationTool.FindForInTypeAsString TermExprType=', ExprTypeToString(TermExprType)); {$ENDIF} // search operator enumerator if FindOperatorEnumerator(CursorNode,TermExprType,foeEnumeratorCurrentExprType, OperatorExprType) then begin {$IFDEF ShowExprEval} DebugLn(['TFindDeclarationTool.FindForInTypeAsString Operator=',ExprTypeToString(OperatorExprType)]); {$ENDIF} ExprType:=OperatorExprType; Result:=FindExprTypeAsString(ExprType,TermPos.StartPos,Params); exit; end; // use default enumerators case TermExprType.Desc of xtContext: begin case TermExprType.Context.Node.Desc of ctnClass: begin if not TermExprType.Context.Tool.FindEnumeratorOfClass( TermExprType.Context.Node,true,ExprType) then RaiseTermHasNoIterator; Result:=FindExprTypeAsString(ExprType,TermPos.StartPos,Params); end; ctnSetType: if TermExprType.Context.Tool.FindEnumerationTypeOfSetType( TermExprType.Context.Node,ExprType.Context) then begin ExprType.Desc:=xtContext; Result:=FindExprTypeAsString(ExprType,TermPos.StartPos,Params); end; ctnRangedArrayType,ctnOpenArrayType: if TermExprType.Context.Tool.FindElementTypeOfArrayType( TermExprType.Context.Node,ExprType) then begin Result:=FindExprTypeAsString(ExprType,TermPos.StartPos,Params); end; else RaiseTermHasNoIterator; end; end; xtNone, xtChar, xtWideChar, xtReal, xtSingle, xtDouble, xtExtended, xtCurrency, xtComp, xtInt64, xtCardinal, xtQWord, xtBoolean, xtByteBool, xtWordBool, xtLongBool, xtQWordBool, xtPointer, xtFile, xtText, xtConstOrdInteger, xtConstReal, xtConstBoolean, xtLongint, xtLongWord, xtWord, xtSmallInt, xtShortInt, xtByte, xtCompilerFunc, xtVariant, xtNil: RaiseTermHasNoIterator; xtString, xtAnsiString, xtShortString, xtPChar, xtConstString: begin ExprType.Desc:=xtChar; Result:=ExpressionTypeDescNames[ExprType.Desc]; end; xtWideString, xtUnicodeString: begin ExprType.Desc:=xtWideChar; Result:=ExpressionTypeDescNames[ExprType.Desc]; end; xtConstSet: RaiseTermHasNoIterator; // ToDo else DebugLn('TFindDeclarationTool.FindForInTypeAsString TermExprType=', ExprTypeToString(TermExprType)); RaiseTermHasNoIterator; end; {$IFDEF ShowExprEval} DebugLn('TFindDeclarationTool.FindForInTypeAsString Result=',Result); {$ENDIF} end; function TFindDeclarationTool.FindEnumeratorOfClass(ClassNode: TCodeTreeNode; ExceptionOnNotFound: boolean; out ExprType: TExpressionType): boolean; var Params: TFindDeclarationParams; ProcTool: TFindDeclarationTool; ProcNode: TCodeTreeNode; EnumeratorContext: TFindContext; PropTool: TFindDeclarationTool; PropNode: TCodeTreeNode; CurrentContext: TFindContext; begin Result:=false; ExprType:=CleanExpressionType; Params:=TFindDeclarationParams.Create; try // search function 'GetEnumerator' Params.ContextNode:=ClassNode; Params.Flags:=[fdfSearchInAncestors]; Params.SetIdentifier(Self,'GetEnumerator',nil); //DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass searching GetEnumerator ...']); if not FindIdentifierInContext(Params) then begin if ExceptionOnNotFound then begin MoveCursorToCleanPos(ClassNode.StartPos); RaiseException(ctsFunctionGetEnumeratorNotFoundInThisClass); end else exit; end; ProcTool:=Params.NewCodeTool; ProcNode:=Params.NewNode; //DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass Proc']); if (ProcNode=nil) or (ProcNode.Desc<>ctnProcedure) then begin if ExceptionOnNotFound then begin MoveCursorToCleanPos(ClassNode.StartPos); RaiseException(ctsFunctionGetEnumeratorNotFoundInThisClass2); end else exit; end; // search function type Params.Clear; Include(Params.Flags,fdfFunctionResult); EnumeratorContext:=ProcTool.FindBaseTypeOfNode(Params,ProcNode); //DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass EnumeratorContext=',FindContextToString(EnumeratorContext)]); if (EnumeratorContext.Node=nil) or (EnumeratorContext.Node.Desc<>ctnClass) then begin if ExceptionOnNotFound then begin ProcTool.MoveCursorToCleanPos(ProcNode.StartPos); ProcTool.RaiseException(ctsResultTypeOfFunctionGetEnumeratorNotFound); end else exit; end; // search 'Current' in enumerator class Params.Clear; Params.ContextNode:=EnumeratorContext.Node; Params.Flags:=[fdfSearchInAncestors]; if ExceptionOnNotFound then Include(Params.Flags,fdfExceptionOnNotFound); Params.SetIdentifier(Self,'Current',nil); //DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass search current ...']); if not FindIdentifierInContext(Params) then exit; PropTool:=Params.NewCodeTool; PropNode:=Params.NewNode; //DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass PropNode=',PropNode.DescAsString]); if (PropNode=nil) or (PropNode.Desc<>ctnProperty) then begin if ExceptionOnNotFound then begin EnumeratorContext.Tool.MoveCursorToCleanPos(EnumeratorContext.Node.StartPos); RaiseException(ctsPropertyCurrentNotFound); end else exit; end; // search type of Current Params.Clear; if ExceptionOnNotFound then Include(Params.Flags,fdfExceptionOnNotFound); //DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass searching property type ...']); CurrentContext:=PropTool.FindBaseTypeOfNode(Params,PropNode); ExprType:=CurrentContext.Tool.ConvertNodeToExpressionType( CurrentContext.Node,Params); //DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass ExprType=',ExprTypeToString(ExprType)]); Result:=ExprType.Desc<>xtNone; finally Params.Free; end; end; function TFindDeclarationTool.FindOperatorEnumerator(Node: TCodeTreeNode; ExprType: TExpressionType; Need: TFindOperatorEnumerator; out ResultExprType: TExpressionType): boolean; // find a compatible operator overload for 'enumerator' with a parameter // compatible to ExprType // for example: // operator enumerator (AList: TMyList): TMyListEnumerator; var Params: TFindDeclarationParams; OperatorTool: TFindDeclarationTool; OperatorNode: TCodeTreeNode; ClassContext: TFindContext; EnumeratorCurrentTool: TFindDeclarationTool; EnumeratorCurrentNode: TCodeTreeNode; begin Result:=false; ResultExprType:=CleanExpressionType; Params:=TFindDeclarationParams.Create; try // search compatible operator enumerator Params.ContextNode:=Node; Params.Flags:=[fdfSearchInParentNodes]; Params.Data:=@ExprType; Params.SetIdentifier(Self,'Enumerator',@CheckOperatorEnumerator); {$IFDEF ShowExprEval} DebugLn(['TFindDeclarationTool.FindOperatorEnumerator searching operator enumerator ...']); {$ENDIF} if not FindIdentifierInContext(Params) then exit; // operator found // now check if it is valid OperatorTool:=Params.NewCodeTool; OperatorNode:=Params.NewNode; {$IFDEF ShowExprEval} DebugLn(['TFindDeclarationTool.FindOperatorEnumerator Operator="',OperatorTool.ExtractNode(OperatorNode,[]),'"']); {$ENDIF} if Need=foeProcNode then begin ResultExprType.Desc:=xtContext; ResultExprType.Context.Tool:=OperatorTool; ResultExprType.Context.Node:=OperatorNode; exit(true); end; // search class node Params.Clear; Params.Flags:=[fdfFunctionResult]; {$IFDEF ShowExprEval} DebugLn(['TFindDeclarationTool.FindOperatorEnumerator searching operator result object ...']); {$ENDIF} ClassContext:=OperatorTool.FindBaseTypeOfNode(Params,OperatorNode); {$IFDEF ShowExprEval} DebugLn(['TFindDeclarationTool.FindOperatorEnumerator ClassContext=',FindContextToString(ClassContext)]); {$ENDIF} case ClassContext.Node.Desc of ctnClass,ctnObject,ctnClassInterface: ; else OperatorTool.MoveCursorToNodeStart(OperatorNode); OperatorTool.RaiseException('operator enumerator result type is not object'); end; if Need=foeResultClassNode then begin ResultExprType.Desc:=xtContext; ResultExprType.Context:=ClassContext; exit(true); end; // search property with modifier enumerator Current Params.Clear; Params.ContextNode:=ClassContext.Node; Params.Flags:=[fdfSearchInAncestors,fdfCollect]; Params.SetIdentifier(Self,'',@CheckModifierEnumeratorCurrent); {$IFDEF ShowExprEval} DebugLn(['TFindDeclarationTool.FindOperatorEnumerator searching enumerator current ...']); {$ENDIF} if not ClassContext.Tool.FindIdentifierInContext(Params) then begin ClassContext.Tool.MoveCursorToNodeStart(ClassContext.Node); ClassContext.Tool.RaiseException('enumerator ''current'' not found'); end; EnumeratorCurrentTool:=Params.NewCodeTool; EnumeratorCurrentNode:=Params.NewNode; if Need=foeEnumeratorCurrentNode then begin ResultExprType.Desc:=xtContext; ResultExprType.Context.Tool:=EnumeratorCurrentTool; ResultExprType.Context.Node:=EnumeratorCurrentNode; exit(true); end; // search expression type of 'enumerator current' Params.Clear; Params.Flags:=[fdfFunctionResult]; {$IFDEF ShowExprEval} DebugLn(['TFindDeclarationTool.FindOperatorEnumerator searching enumerator current result ...']); {$ENDIF} ResultExprType:=EnumeratorCurrentTool.ConvertNodeToExpressionType( EnumeratorCurrentNode,Params); {$IFDEF ShowExprEval} DebugLn(['TFindDeclarationTool.FindOperatorEnumerator enumerator current result=',ExprTypeToString(ResultExprType)]); {$ENDIF} Result:=true; finally Params.Free; end; end; function TFindDeclarationTool.FindEnumerationTypeOfSetType( SetTypeNode: TCodeTreeNode; out Context: TFindContext): boolean; var Params: TFindDeclarationParams; p: LongInt; begin Result:=false; if (SetTypeNode=nil) or (SetTypeNode.Desc<>ctnSetType) then exit; MoveCursorToNodeStart(SetTypeNode); ReadNextAtom; // set if not UpAtomIs('SET') then exit; ReadNextAtom; // of if not UpAtomIs('OF') then exit; ReadNextAtom; if not IsIdentStartChar[Src[CurPos.StartPos]] then // set of () exit; Params:=TFindDeclarationParams.Create; try Params.Flags:=fdfDefaultForExpressions; Params.ContextNode:=SetTypeNode; p:=CurPos.StartPos; Params.SetIdentifier(Self,@Src[p],nil); if not FindIdentifierInContext(Params) then exit; if (Params.NewNode=nil) or (Params.NewNode.Desc<>ctnTypeDefinition) or (Params.NewNode.FirstChild=nil) or (Params.NewNode.FirstChild.Desc<>ctnEnumerationType) then begin MoveCursorToCleanPos(p); ReadNextAtom; RaiseStringExpectedButAtomFound(ctsEnumerationType); end; Context.Tool:=Params.NewCodeTool; Context.Node:=Params.NewNode; Result:=true; finally Params.Free; end; end; function TFindDeclarationTool.FindElementTypeOfArrayType( ArrayNode: TCodeTreeNode; out ExprType: TExpressionType): boolean; var Params: TFindDeclarationParams; p: LongInt; begin Result:=false; ExprType:=CleanExpressionType; if (ArrayNode=nil) then exit; if (ArrayNode.Desc<>ctnOpenArrayType) and (ArrayNode.Desc<>ctnRangedArrayType) then exit; MoveCursorToNodeStart(ArrayNode); ReadNextAtom; // array if not UpAtomIs('ARRAY') then exit; ReadNextAtom; // of if CurPos.Flag=cafEdgedBracketOpen then begin ReadTilBracketClose(true); ReadNextAtom; end; if not UpAtomIs('OF') then exit; ReadNextAtom; if not AtomIsIdentifier(false) then exit; Params:=TFindDeclarationParams.Create; try Params.Flags:=fdfDefaultForExpressions; Params.ContextNode:=ArrayNode; p:=CurPos.StartPos; Params.SetIdentifier(Self,@Src[p],nil); ExprType:=FindExpressionResultType(Params,p,-1); Result:=true; finally Params.Free; end; end; function TFindDeclarationTool.CheckOperatorEnumerator( Params: TFindDeclarationParams; const FoundContext: TFindContext ): TIdentifierFoundResult; var Node: TCodeTreeNode; ExprType: TExpressionType; Params2: TFindDeclarationParams; begin Result:=ifrProceedSearch; {$IFDEF ShowExprEval} DebugLn(['TFindDeclarationTool.CheckOperatorEnumerator ',FindContextToString(FoundContext)]); {$ENDIF} if not FoundContext.Tool.NodeIsOperator(FoundContext.Node) then exit; FoundContext.Tool.BuildSubTreeForProcHead(FoundContext.Node); Node:=FoundContext.Node.FirstChild; if (Node=nil) or (Node.Desc<>ctnProcedureHead) then exit; Node:=Node.FirstChild; if (Node=nil) or (Node.Desc<>ctnParameterList) then exit; Node:=Node.FirstChild; if (Node=nil) then exit; if Node.NextBrother<>nil then exit; ExprType:=PExpressionType(Params.Data)^; Params2:=TFindDeclarationParams.Create; try if IsCompatible(Node,ExprType,Params2)=tcIncompatible then exit; finally Params2.Free; end; {$IFDEF ShowExprEval} DebugLn(['TFindDeclarationTool.CheckOperatorEnumerator FOUND ',FoundContext.Tool.ExtractNode(FoundContext.Node,[])]); {$ENDIF} Result:=ifrSuccess; end; function TFindDeclarationTool.CheckModifierEnumeratorCurrent( Params: TFindDeclarationParams; const FoundContext: TFindContext ): TIdentifierFoundResult; begin Result:=ifrProceedSearch; //DebugLn(['TFindDeclarationTool.CheckModifierEnumeratorCurrent ',FindContextToString(FoundContext)]); case FoundContext.Node.Desc of ctnProperty: begin if FoundContext.Tool.PropertyHasSpecifier(FoundContext.Node,'Enumerator',false) then begin FoundContext.Tool.ReadNextAtom; if FoundContext.Tool.UpAtomIs('CURRENT') then Result:=ifrSuccess; end; end; end; end; function TFindDeclarationTool.IsTermEdgedBracket(TermPos: TAtomPosition; out EdgedBracketsStartPos: integer): boolean; { allowed: - at least one edged brackets - identifiers - functions - operators: + and - [a,b]+[c]-D()*inherited E not allowed: []<>[] } var Lvl: Integer; EndPos: LongInt; begin Result:=false; EdgedBracketsStartPos:=0; EndPos:=TermPos.EndPos; if EndPos>SrcLen then EndPos:=SrcLen; MoveCursorToCleanPos(TermPos.StartPos); Lvl:=0; repeat ReadNextAtom; if (CurPos.StartPos>=EndPos) then break; case CurPos.Flag of cafRoundBracketOpen: ReadTilBracketClose(false); cafEdgedBracketOpen: begin inc(Lvl); if (Lvl=1) and (EdgedBracketsStartPos<1) then begin if (LastAtoms.Count=0) or LastAtomIs(-1,'+') or LastAtomIs(-1,'-') or LastAtomIs(-1,'*') then EdgedBracketsStartPos:=CurPos.StartPos; end; end; cafEdgedBracketClose: dec(Lvl); cafWord: ; cafComma: if Lvl<1 then break else if Lvl>1 then exit; else if AtomIsChar('+') or AtomIsChar('-') then begin // allowed end else begin // not allowed exit; end; end; until false; Result:=EdgedBracketsStartPos>0; end; function TFindDeclarationTool.IsTermNamedPointer(TermPos: TAtomPosition; out ExprType: TExpressionType): boolean; // check if TermPos is @Name and a pointer (= ^Name) can be found var SubExprType: TExpressionType; Node: TCodeTreeNode; PointerTool: TFindDeclarationTool; Params: TFindDeclarationParams; PointerNode: TCodeTreeNode; begin Result:=false; MoveCursorToCleanPos(TermPos.StartPos); ReadNextAtom; if not AtomIsChar('@') then exit; // a pointer ExprType:=CleanExpressionType; ExprType.Desc:=xtPointer; Result:=true; // try to find a name ReadNextAtom; if CurPos.StartPos>SrcLen then exit; Params:=TFindDeclarationParams.Create; try Params.ContextNode:=FindDeepestNodeAtPos(CurPos.StartPos,true); SubExprType:=FindExpressionResultType(Params,CurPos.StartPos,-1); finally Params.Free; end; //debugln(['TFindDeclarationTool.IsTermNamedPointer SubExprType=',ExprTypeToString(SubExprType)]); if SubExprType.Desc in xtAllPredefinedTypes then begin ExprType.SubDesc:=SubExprType.Desc; exit(true); end else if (SubExprType.Desc=xtContext) then begin Node:=SubExprType.Context.Node; if (not (Node.Desc in AllIdentifierDefinitions)) and (Node.Parent<>nil) and (Node.Parent.Desc in AllIdentifierDefinitions) then Node:=Node.Parent; if (Node.Desc in AllIdentifierDefinitions) then begin PointerTool:=SubExprType.Context.Tool; PointerNode:=PointerTool.FindPointerOfIdentifier(Node); if PointerNode<>nil then begin ExprType:=CleanExpressionType; ExprType.Desc:=xtContext; ExprType.SubDesc:=xtNone; ExprType.Context.Tool:=PointerTool; ExprType.Context.Node:=PointerNode; exit(true); end; end; end; end; function TFindDeclarationTool.FindSetOfEnumerationType(EnumNode: TCodeTreeNode ): TCodeTreeNode; // search in the same type section for a 'set of ' node var p: PChar; function IsSetOfEnum(Node: TCodeTreeNode): boolean; begin Result:=false; if (Node.Desc<>ctnTypeDefinition) or (Node.FirstChild=nil) or (Node.FirstChild.Desc<>ctnSetType) then exit; MoveCursorToNodeStart(Node.FirstChild); ReadNextAtom; // read set if not UpAtomIs('SET') then exit; ReadNextAtom; // read of if not UpAtomIs('OF') then exit; ReadNextAtom; // read of if CurPos.Flag<>cafWord then exit; Result:=CompareSrcIdentifiers(CurPos.StartPos,p); end; begin if EnumNode.Desc=ctnEnumIdentifier then EnumNode:=EnumNode.Parent; if EnumNode.Desc=ctnEnumerationType then EnumNode:=EnumNode.Parent; p:=@Src[EnumNode.StartPos]; Result:=EnumNode.Parent.FirstChild; while Result<>nil do begin if IsSetOfEnum(Result) then exit; Result:=Result.NextBrother; end; end; function TFindDeclarationTool.FindPointerOfIdentifier( TypeNode: TCodeTreeNode): TCodeTreeNode; // search in the same type section for a '^identifier' node var p: PChar; function IsPointerOf(Node: TCodeTreeNode): boolean; begin Result:=false; if (Node.Desc<>ctnTypeDefinition) or (Node.FirstChild=nil) or (Node.FirstChild.Desc<>ctnPointerType) then exit; MoveCursorToNodeStart(Node.FirstChild); ReadNextAtom; // read ^ if not AtomIsChar('^') then exit; ReadNextAtom; // read identifier if not AtomIsIdentifier(false) then exit; Result:=CompareSrcIdentifiers(CurPos.StartPos,p); end; begin if TypeNode.Desc<>ctnTypeDefinition then exit(nil); p:=@Src[TypeNode.StartPos]; Result:=TypeNode.Parent.FirstChild; while Result<>nil do begin if IsPointerOf(Result) then exit; Result:=Result.NextBrother; end; end; function TFindDeclarationTool.FindExprTypeAsString( const ExprType: TExpressionType; TermCleanPos: integer; Params: TFindDeclarationParams): string; procedure RaiseTermNotSimple; begin if TermCleanPos<1 then TermCleanPos:=1; MoveCursorToCleanPos(TermCleanPos); RaiseException(ctsTermNotSimple); end; var FindContext: TFindContext; ANode: TCodeTreeNode; begin {$IFDEF ShowExprEval} DebugLn('TFindDeclarationTool.FindExprTypeAsString ExprTypeToString=', ExprTypeToString(ExprType)); {$ENDIF} case ExprType.Desc of xtNone: RaiseTermNotSimple; xtContext: begin FindContext:=ExprType.Context; if not (FindContext.Node.Desc in AllIdentifierDefinitions) then begin if (FindContext.Node.Parent<>nil) and (FindContext.Node.Parent.Desc in AllIdentifierDefinitions) then begin FindContext.Node:=FindContext.Node.Parent; end else begin Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors, fdfTopLvlResolving,fdfFunctionResult]; FindContext:=ExprType.Context.Tool.FindBaseTypeOfNode(Params, ExprType.Context.Node); end; end; // ToDo: PPU, PPW, DCU case FindContext.Node.Desc of ctnTypeDefinition: Result:=GetIdentifier( @FindContext.Tool.Src[FindContext.Node.StartPos]); ctnVarDefinition,ctnConstDefinition: begin ANode:=FindContext.Tool.FindTypeNodeOfDefinition(FindContext.Node); if (ANode=nil) or (ANode.Desc<>ctnIdentifier) then RaiseTermNotSimple; Result:=GetIdentifier(@FindContext.Tool.Src[ANode.StartPos]); end; ctnClass, ctnClassInterface, ctnDispinterface, ctnObject, ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass: if (FindContext.Node.Parent<>nil) and (FindContext.Node.Parent.Desc in [ctnTypeDefinition,ctnGenericType]) then Result:=GetIdentifier( @FindContext.Tool.Src[FindContext.Node.Parent.StartPos]); ctnEnumerationType: if (FindContext.Node.Parent<>nil) and (FindContext.Node.Parent.Desc=ctnTypeDefinition) then Result:=GetIdentifier( @FindContext.Tool.Src[FindContext.Node.Parent.StartPos]); ctnProperty,ctnGlobalProperty: begin FindContext.Tool.MoveCursorToPropType(FindContext.Node); Result:=FindContext.Tool.GetAtom; end; end; if Result='' then begin DebugLn('TFindDeclarationTool.FindExprTypeAsString ContextNode=', FindContext.Node.DescAsString); RaiseTermNotSimple; end; end; xtChar, xtWideChar, xtReal, xtSingle, xtDouble, xtExtended, xtCurrency, xtComp, xtInt64, xtCardinal, xtQWord, xtPChar: Result:=ExpressionTypeDescNames[ExprType.Desc]; xtPointer: begin case ExprType.SubDesc of xtChar, xtWideChar, xtReal, xtSingle, xtDouble, xtExtended, xtCurrency, xtComp, xtInt64, xtCardinal, xtQWord, xtBoolean, xtByteBool, xtWordBool, xtLongBool, xtQWordBool, xtString, xtAnsiString, xtShortString, xtWideString, xtUnicodeString, xtLongint, xtLongWord, xtWord, xtSmallInt, xtShortInt, xtByte: Result:='P'+ExpressionTypeDescNames[ExprType.SubDesc]; else Result:=ExpressionTypeDescNames[xtPointer]; end; end; xtFile, xtText, xtLongint, xtLongWord, xtSmallInt, xtShortInt, xtByte, xtWord: Result:=ExpressionTypeDescNames[ExprType.Desc]; xtBoolean, xtByteBool, xtWordBool, xtLongBool, xtQWordBool: Result:=ExpressionTypeDescNames[xtBoolean]; xtString, xtAnsiString, xtShortString: Result:=ExpressionTypeDescNames[xtString]; xtWideString: Result:=ExpressionTypeDescNames[ExprType.Desc]; xtConstOrdInteger: Result:='Integer'; xtConstString: Result:=ExpressionTypeDescNames[xtString]; xtConstReal: Result:=ExpressionTypeDescNames[xtExtended]; xtConstSet: begin RaiseTermNotSimple; end; xtConstBoolean: Result:=ExpressionTypeDescNames[xtBoolean]; xtNil: RaiseTermNotSimple; else DebugLn('TCodeCompletionCodeTool.FindExprTypeAsString ExprTypeToString=', ExprTypeToString(ExprType)); RaiseTermNotSimple; end; end; { TFindDeclarationParams } procedure TFindDeclarationParams.FreeFoundProc(aFoundProc: PFoundProc; FreeNext: boolean); var Next: PFoundProc; begin //DebugLn(['TFindDeclarationParams.FreeFoundProc ',dbgs(aFoundProc)]); while aFoundProc<>nil do begin if (aFoundProc^.Owner<>Self) and ((FirstFoundProc=aFoundProc) or (aFoundProc^.Prior<>nil) or (aFoundProc^.Next<>nil)) then raise Exception.Create('FoundProc is in list, but not owned'); if FreeNext then Next:=aFoundProc^.Next else Next:=nil; RemoveFoundProcFromList(aFoundProc); with aFoundProc^ do begin //DebugLn(['TFindDeclarationParams.FreeFoundProc ExprInputList=',dbgs(ExprInputList)]); if ExprInputList<>nil then FreeAndNil(ExprInputList); //DebugLn(['TFindDeclarationParams.FreeFoundProc ParamCompatibilityList=',dbgs(ParamCompatibilityList)]); if ParamCompatibilityList<>nil then begin FreeMem(ParamCompatibilityList); ParamCompatibilityList:=nil; end; CacheValid:=false; end; //DebugLn(['TFindDeclarationParams.FreeFoundProc Dispose ',dbgs(aFoundProc)]); Dispose(aFoundProc); aFoundProc:=Next; end; end; procedure TFindDeclarationParams.RemoveFoundProcFromList(aFoundProc: PFoundProc ); begin //DebugLn(['TFindDeclarationParams.RemoveFoundProcFromList ',dbgs(aFoundProc)]); if FirstFoundProc=aFoundProc then FirstFoundProc:=aFoundProc^.Next; if LastFoundProc=aFoundProc then LastFoundProc:=aFoundProc^.Next; with aFoundProc^ do begin if Next<>nil then Next^.Prior:=Prior; if Prior<>nil then Prior^.Next:=Next; Prior:=nil; Next:=nil; Owner:=nil; end; end; constructor TFindDeclarationParams.Create; begin inherited Create; Clear; end; destructor TFindDeclarationParams.Destroy; begin Clear; FreeFoundProc(FirstFoundProc,true); inherited Destroy; end; procedure TFindDeclarationParams.Clear; begin ClearInput; ClearFoundProc; ClearResult(false); OnTopLvlIdentifierFound:=nil; end; procedure TFindDeclarationParams.Load(Input: TFindDeclarationInput; FreeInput: boolean); // set FreeInput to true, if the Input is not needed anymore and the dynamic // data can be freed. begin Flags:=Input.Flags; Identifier:=Input.Identifier; ContextNode:=Input.ContextNode; OnIdentifierFound:=Input.OnIdentifierFound; IdentifierTool:=Input.IdentifierTool; if FoundProc<>Input.FoundProc then begin // free current FoundProc (probably not yet saved) if FoundProc<>nil then ClearFoundProc; // use saved FoundProc FoundProc:=Input.FoundProc; // free all FoundProcs, that were saved later if (FoundProc<>nil) then begin FreeFoundProc(FoundProc^.Next,true); if FreeInput then begin Input.FoundProc:=nil; RemoveFoundProcFromList(FoundProc); end; end; end; end; procedure TFindDeclarationParams.Save(out Input: TFindDeclarationInput); begin Input.Flags:=Flags; Input.Identifier:=Identifier; Input.ContextNode:=ContextNode; Input.OnIdentifierFound:=OnIdentifierFound; Input.IdentifierTool:=IdentifierTool; Input.FoundProc:=FoundProc; if (FoundProc<>nil) and (FoundProc^.Owner=nil) then begin // add to list of saves FoundProcs //DebugLn(['TFindDeclarationParams.Save ',dbgs(FoundProc)]); FoundProc^.Prior:=LastFoundProc; if LastFoundProc<>nil then LastFoundProc^.Next:=FoundProc; LastFoundProc:=FoundProc; if FirstFoundProc=nil then FirstFoundProc:=FoundProc; FoundProc^.Owner:=Self; end; end; procedure TFindDeclarationParams.ClearResult(CopyCacheFlags: boolean); begin NewPos.Code:=nil; NewPos.X:=-1; NewPos.Y:=-1; NewTopLine:=-1; NewNode:=nil; NewCleanPos:=-1; NewCodeTool:=nil; NewFlags:=[]; if CopyCacheFlags and (fdfDoNotCache in Flags) then Include(NewFlags,fodDoNotCache); end; procedure TFindDeclarationParams.SetResult(const AFindContext: TFindContext); begin ClearResult(true); NewCodeTool:=AFindContext.Tool; NewNode:=AFindContext.Node; end; procedure TFindDeclarationParams.SetResult(ANewCodeTool: TFindDeclarationTool; ANewNode: TCodeTreeNode); begin ClearResult(true); NewCodeTool:=ANewCodeTool; NewNode:=ANewNode; {$IFDEF CheckNodeTool}if NewCodeTool<>nil then NewCodeTool.CheckNodeTool(NewNode);{$ENDIF} end; procedure TFindDeclarationParams.SetResult(ANewCodeTool: TFindDeclarationTool; ANewNode: TCodeTreeNode; ANewCleanPos: integer); begin ClearResult(true); NewCodeTool:=ANewCodeTool; NewNode:=ANewNode; NewCleanPos:=ANewCleanPos; {$IFDEF CheckNodeTool}if NewCodeTool<>nil then NewCodeTool.CheckNodeTool(NewNode);{$ENDIF} end; procedure TFindDeclarationParams.ConvertResultCleanPosToCaretPos; begin NewPos.Code:=nil; if NewCodeTool<>nil then begin if (NewCleanPos>=1) then NewCodeTool.CleanPosToCaretAndTopLine(NewCleanPos,NewPos,NewTopLine) else if (NewNode<>nil) then NewCodeTool.CleanPosToCaretAndTopLine(NewNode.StartPos,NewPos,NewTopLine); end; end; procedure TFindDeclarationParams.ClearInput; begin Flags:=[]; Identifier:=nil; ContextNode:=nil; OnIdentifierFound:=nil; IdentifierTool:=nil; end; procedure TFindDeclarationParams.ClearFoundProc; begin if FoundProc=nil then exit; //DebugLn(['TFindDeclarationParams.ClearFoundProc ',dbgs(FoundProc),' Saved=',FoundProc^.Owner<>nil]); if FoundProc^.Owner=nil then // the FoundProc is not saved FreeFoundProc(FoundProc,true) else if FoundProc^.Next<>nil then // the FoundProc is saved (release the later FoundProcs, // which are not needed any more) FreeFoundProc(FoundProc^.Next,true); FoundProc:=nil; end; procedure TFindDeclarationParams.WriteDebugReport; begin DebugLn('TFindDeclarationParams.WriteDebugReport Self=',DbgS(Self)); // input parameters: DebugLn(' Flags=',FindDeclarationFlagsAsString(Flags)); DebugLn(' Identifier=',GetIdentifier(Identifier)); if ContextNode<>nil then DebugLn(' ContextNode=',ContextNode.DescAsString) else DebugLn(' ContextNode=nil'); if OnIdentifierFound<>nil then DebugLn(' OnIdentifierFound=',TFindDeclarationTool(TMethod(OnIdentifierFound).Data).MainFilename); if IdentifierTool<>nil then DebugLn(' IdentifierTool=',IdentifierTool.MainFilename) else DebugLn(' IdentifierTool=nil'); if FoundProc<>nil then begin if FoundProc^.Context.Node<>nil then DebugLn(' FoundProc=',FoundProc^.Context.Tool.CleanPosToStr(FoundProc^.Context.Node.StartPos,true)) else DebugLn(' FoundProc<>nil'); end; // global params if OnTopLvlIdentifierFound<>nil then DebugLn(' OnTopLvlIdentifierFound=',TFindDeclarationTool(TMethod(OnTopLvlIdentifierFound).Code).MainFilename); // results: if NewNode<>nil then DebugLn(' NewNode=',NewNode.DescAsString) else DebugLn(' NewNode=nil'); DebugLn(' NewCleanPos=',dbgs(NewCleanPos)); if NewCodeTool<>nil then DebugLn(' NewCodeTool=',NewCodeTool.MainFilename) else DebugLn(' NewCodeTool=nil'); if NewPos.Code<>nil then DebugLn(' NewPos=',NewPos.Code.Filename,' x=',dbgs(NewPos.X),' y=',dbgs(NewPos.Y),' topline=',dbgs(NewTopLine)) else DebugLn(' NewPos=nil'); DebugLn(' NewFlags=',FoundDeclarationFlagsAsString(NewFlags)); DebugLn(''); end; procedure TFindDeclarationParams.SetIdentifier( NewIdentifierTool: TFindDeclarationTool; NewIdentifier: PChar; NewOnIdentifierFound: TOnIdentifierFound); begin Identifier:=NewIdentifier; IdentifierTool:=NewIdentifierTool; OnIdentifierFound:=NewOnIdentifierFound; ClearFoundProc; end; procedure TFindDeclarationParams.SetFirstFoundProc( const ProcContext: TFindContext); begin //DebugLn(['TFindDeclarationParams.SetFirstFoundProc Old=',dbgs(FoundProc)]); if FoundProc<>nil then ClearFoundProc; New(FoundProc); //DebugLn(['TFindDeclarationParams.SetFirstFoundProc New=',dbgs(FoundProc)]); FillChar(FoundProc^,SizeOf(TFoundProc),0); FoundProc^.Context:=ProcContext; end; procedure TFindDeclarationParams.ChangeFoundProc( const ProcContext: TFindContext; ProcCompatibility: TTypeCompatibility; ParamCompatibilityList: TTypeCompatibilityList); begin FoundProc^.Context:=ProcContext; FoundProc^.ProcCompatibility:=ProcCompatibility; if (FoundProc^.ParamCompatibilityList<>ParamCompatibilityList) then begin //DebugLn(['TFindDeclarationParams.ChangeFoundProc Old ParamCompatibilityList=',dbgs(FoundProc^.ParamCompatibilityList)]); if (FoundProc^.ParamCompatibilityList<>nil) then FreeMem(FoundProc^.ParamCompatibilityList); FoundProc^.ParamCompatibilityList:=ParamCompatibilityList; //DebugLn(['TFindDeclarationParams.ChangeFoundProc New ParamCompatibilityList=',dbgs(FoundProc^.ParamCompatibilityList)]); end; end; function TFindDeclarationParams.IsFinal: boolean; begin Result:=(FoundProc=nil) or (FoundProc^.CacheValid and (FoundProc^.ProcCompatibility=tcExact)); end; procedure TFindDeclarationParams.PrettifyResult; begin // adjust result for nicer position if (NewNode<>nil) then begin {$IFDEF CheckNodeTool} if NewCodeTool<>nil then NewCodeTool.CheckNodeTool(NewNode); {$ENDIF} if (NewNode.Desc=ctnProcedure) and (NewNode.FirstChild<>nil) and (NewNode.FirstChild.Desc=ctnProcedureHead) then begin // Instead of jumping to the procedure keyword, // jump to the procedure name NewNode:=NewNode.FirstChild; NewCleanPos:=NewNode.StartPos; end; if (NewNode.Desc=ctnGenericType) and (NewNode.FirstChild<>nil) then begin // Instead of jumping to the generic keyword, // jump to the name NewNode:=NewNode.FirstChild; NewCleanPos:=NewNode.StartPos; end; end; end; procedure TFindDeclarationParams.SetResult( NodeCacheEntry: PCodeTreeNodeCacheEntry); begin ClearResult(true); NewCodeTool:=TFindDeclarationTool(NodeCacheEntry^.NewTool); NewNode:=NodeCacheEntry^.NewNode; NewCleanPos:=NodeCacheEntry^.NewCleanPos; end; { TExprTypeList } destructor TExprTypeList.Destroy; begin if Items<>nil then FreeMem(Items); end; function TExprTypeList.AsString: string; var i: integer; begin Result:=''; for i:=0 to Count-1 do begin Result:=Result+'{'+IntToStr(i)+'/'+IntToStr(Count)+':'+ExprTypeToString(Items[i])+'}'+LineEnding; end; end; function TExprTypeList.CalcMemSize: PtrUInt; begin Result:=PtrUInt(InstanceSize) +PtrUInt(FCapacity)*SizeOf(TExpressionType); end; procedure TExprTypeList.SetCapacity(const AValue: integer); var NewSize: integer; begin if FCapacity=AValue then exit; FCapacity:=AValue; NewSize:=FCapacity*SizeOf(TExpressionType); if Items=nil then GetMem(Items,NewSize) else ReAllocMem(Items,NewSize); if Count>Capacity then Count:=Capacity; end; procedure TExprTypeList.Grow; begin Capacity:=Capacity*2+4; end; procedure TExprTypeList.Add(const ExprType: TExpressionType); begin inc(Count); if Count>Capacity then Grow; Items[Count-1]:=ExprType; end; procedure TExprTypeList.AddFirst(const ExprType: TExpressionType); begin inc(Count); if Count>Capacity then Grow; if Count>1 then Move(Items[0],Items[1],SizeOf(TExpressionType)*(Count-1)); Items[0]:=ExprType; end; end.