1 {
2 ***************************************************************************
3 * *
4 * This source is free software; you can redistribute it and/or modify *
5 * it under the terms of the GNU General Public License as published by *
6 * the Free Software Foundation; either version 2 of the License, or *
7 * (at your option) any later version. *
8 * *
9 * This code is distributed in the hope that it will be useful, but *
10 * WITHOUT ANY WARRANTY; without even the implied warranty of *
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
12 * General Public License for more details. *
13 * *
14 * A copy of the GNU General Public License is available on the World *
15 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
16 * obtain it by writing to the Free Software Foundation, *
17 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
18 * *
19 ***************************************************************************
20
21 Author: Mattias Gaertner
22
23 Abstract:
24 TFindDeclarationTool enhances the TPascalReaderTool with the ability
25 to find the source position or code tree node of a declaration.
26
27
28 ToDo:
29 - high type expression evaluation
30 (i.e. at the moment: integer+integer=longint
31 wanted: integer+integer=integer)
32 - make @Proc context sensitive (started, but not complete)
33 - operator overloading
34 - ppu, dcu files
35 - many things, search for 'ToDo'
36 }
37 unit FindDeclarationTool;
38
39 {$ifdef FPC}{$mode objfpc}{$endif}{$H+}
40
41 interface
42
43 {$I codetools.inc}
44
45 // activate for debugging:
46
47 // mem check
48 { $DEFINE MEM_CHECK}
49
50 // verbosity
51 { $DEFINE CTDEBUG}
52 { $DEFINE ShowTriedFiles}
53 { $DEFINE ShowTriedContexts}
54 { $DEFINE ShowTriedBaseContexts}
55 { $DEFINE ShowTriedParentContexts}
56 { $DEFINE ShowTriedIdentifiers}
57 { $DEFINE ShowTriedUnits}
58 { $DEFINE ShowExprEval}
59 { $DEFINE ShowForInEval}
60 { $DEFINE ShowFoundIdentifier}
61 { $DEFINE ShowNodeCache}
62 { $DEFINE ShowBaseTypeCache}
63 { $DEFINE ShowCacheDependencies}
64 { $DEFINE ShowCollect}
65 { $DEFINE ShowProcSearch}
66 { $DEFINE VerboseFindDeclarationFail}
67 { $DEFINE DebugAddToolDependency}
68 { $DEFINE VerboseCPS}
69 { $DEFINE VerboseFindDeclarationAndOverload}
70 { $DEFINE VerboseFindFileAtCursor}
71
72 {$IFDEF CTDEBUG}{$DEFINE DebugPrefix}{$ENDIF}
73 {$IFDEF ShowTriedIdentifiers}{$DEFINE DebugPrefix}{$ENDIF}
74 {$IFDEF ShowTriedContexts}{$DEFINE DebugPrefix}{$ENDIF}
75 {$IFDEF ShowExprEval}{$DEFINE ShowForInEval}{$ENDIF}
76
77 uses
78 {$IFDEF MEM_CHECK}
79 MemCheck,
80 {$ENDIF}
81 Classes, SysUtils, Laz_AVL_Tree,
82 // LazUtils
83 LazFileUtils, LazUtilities,
84 // Codetools
85 CodeToolsStrConsts, CodeTree, CodeAtom, CustomCodeTool,
86 SourceLog, KeywordFuncLists, BasicCodeTools, LinkScanner, CodeCache,
87 DirectoryCacher, PascalParserTool, PascalReaderTool, FileProcs,
88 DefineTemplates, FindDeclarationCache;
89
90 type
91 TFindDeclarationTool = class;
92
93 //----------------------------------------------------------------------------
94 // variable atoms
95
96 TVariableAtomType = (
97 vatNone, // undefined
98 vatSpace, // empty or space
99 vatIdentifier, // an identifier
100 vatPreDefIdentifier, // an identifier with special meaning to the compiler
101 vatPoint, // .
102 vatAS, // AS keyword
103 vatINHERITED, // INHERITED keyword
104 vatUp, // ^
105 vatRoundBracketOpen, // (
106 vatRoundBracketClose,// )
107 vatEdgedBracketOpen, // [
108 vatEdgedBracketClose,// ]
109 vatAddrOp, // @
110 vatKeyword, // other keywords
111 vatNumber, // decimal, & octal, % binary, $ hex
112 vatStringConstant // '' or #
113 );
114
115 const
116 // for nicer debugging output
117 VariableAtomTypeNames: array[TVariableAtomType] of string =
118 ('<None>',
119 'Space',
120 'Ident',
121 'PreDefIdent',
122 'Point',
123 'AS',
124 'INHERITED',
125 'Up^ ',
126 'Bracket(',
127 'Bracket)',
128 'Bracket[',
129 'Bracket]',
130 'AddrOperator@ ',
131 'Keyword',
132 'Number',
133 'StringConstant'
134 );
135
136 type
137 //----------------------------------------------------------------------------
138 // searchpath delimiter is semicolon
endernull139 TOnGetSearchPath = function(Sender: TObject): string of object;
140 TOnGetSrcPathForCompiledUnit =
endernull141 function(Sender: TObject; const Filename: string): string of object;
142
143 //----------------------------------------------------------------------------
onstnull144 TOnGetMethodName = function(const AMethod: TMethod;
145 CheckOwner: TObject): string of object;
146
147 //----------------------------------------------------------------------------
148 // flags/states for searching
149 TFindDeclarationFlag = (
150 fdfSearchInAncestors, // if context is a class, search also in
151 // ancestors/interfaces
152 fdfSearchInParentNodes, // if identifier not found in current context,
153 // proceed in prior nodes on same lvl and parents
154 fdfIgnoreCurContextNode,// skip context and proceed in prior/parent context
155 fdfIgnoreUsedUnits, // stay in current source
156 fdfSearchForward, // instead of searching in prior nodes, search in
157 // next nodes (successors)
158
159 fdfExceptionOnNotFound, // raise exception if identifier not found
160 // predefined identifiers will not raise
161 fdfExceptionOnPredefinedIdent,// raise an exception even if the identifier
162 // is a predefined identifier
163
164 fdfIgnoreClassVisibility,//find inaccessible private+protected fields
165
166 fdfIgnoreMissingParams, // found proc fits, even if parameters are missing
167 fdfOnlyCompatibleProc, // incompatible procs are ignored
168 fdfIgnoreOverloadedProcs,// ignore param lists and take the first proc found
169
170 fdfFindVariable, // do not search for the base type of a variable,
171 // instead return the variable declaration
isnull172 fdfFunctionResult, // if function is found, return result type
173 fdfEnumIdentifier, // do not resolve enum to its enum type
174 fdfFindChildren, // search the class of a 'class of', the interface of a unit
175 fdfSkipClassForward, // when a class forward was found search the class
176
177 fdfCollect, // return every reachable identifier
178 fdfTopLvlResolving, // set, when searching for an identifier of the
179 // top lvl variable. Calling DoOnIdentifierFound.
180 fdfDoNotCache, // result will not be cached
181 fdfExtractOperand, // operand will be extracted
182 fdfPropertyResolving, // used with fdfExtractOperand to resolve properties to getters
183
184 fdfSearchInHelpers, // search in class/record/type helpers too
185 fdfSearchInHelpersInTheEnd, // search in helpers after current class (used with inherited call in helper)
186 fdfTypeType, // do not resolve TMyString = type string;
187 fdfIgnoreOperatorError, // return expression type even if an operator error was found
188 fdfOverrideStringTypesWithFirstParamType // if you search for an expression result type of a "function A(B: string): string", override the result type with type of B expression
189 );
190 TFindDeclarationFlags = set of TFindDeclarationFlag;
191
192 const
193 // masks to pass flags to sub searches
194 fdfGlobals = [fdfExceptionOnNotFound, fdfTopLvlResolving,
195 fdfExtractOperand, fdfPropertyResolving,
196 fdfOverrideStringTypesWithFirstParamType];
197 fdfGlobalsSameIdent = fdfGlobals+[fdfExceptionOnPredefinedIdent,
198 fdfIgnoreMissingParams, fdfIgnoreUsedUnits, fdfDoNotCache,
199 fdfOnlyCompatibleProc, fdfSearchInAncestors, fdfCollect, fdfSearchInHelpers];
200 // initial flags for searches
201 fdfDefaultForExpressions = [fdfSearchInParentNodes, fdfSearchInAncestors, fdfSearchInHelpers,
202 fdfExceptionOnNotFound,fdfIgnoreCurContextNode];
203
204 type
205 // flags/states for result
206 TFoundDeclarationFlag = (
207 fodDoNotCache
208 );
209 TFoundDeclarationFlags = set of TFoundDeclarationFlag;
210
211 //----------------------------------------------------------------------------
212 type
213 TFindDeclarationParams = class;
214
215 TFindContext = record
216 Node: TCodeTreeNode;
217 Tool: TFindDeclarationTool;
218 end;
219 PFindContext = ^TFindContext;
220
221 const
222 CleanFindContext: TFindContext = (Node:nil; Tool:nil);
223
224 type
225 //----------------------------------------------------------------------------
226 { TExpressionTypeDesc describes predefined types
227 The Freepascal compiler can automatically convert them
228 }
229 TExpressionTypeDesc = (
230 xtNone, // undefined
231 xtContext, // a node
232 xtChar, // char
233 xtWideChar, // widechar
234 xtReal, // real
235 xtSingle, // single
236 xtDouble, // double
237 xtExtended, // extended
238 xtCExtended, // cextended
239 xtCurrency, // currency
240 xtComp, // comp
241 xtInt64, // int64
242 xtCardinal, // cardinal
243 xtQWord, // qword
244 xtBoolean, // boolean
245 xtByteBool, // bytebool
246 xtWordBool, // wordbool
247 xtLongBool, // longbool
248 xtQWordBool, // qwordbool
249 xtString, // string
250 xtAnsiString, // ansistring
251 xtShortString, // shortstring
252 xtWideString, // widestring
253 xtUnicodeString,// unicodestring
254 xtPChar, // pchar
255 xtPointer, // pointer
256 xtFile, // file
257 xtText, // text
258 xtConstOrdInteger,// enum, number, integer
259 xtConstString, // string, string constant, char constant
260 xtConstReal, // real number
261 xtConstSet, // [] set
262 xtConstBoolean,// true, false
263 xtLongint, // longint
264 xtLongWord, // longword
265 xtWord, // word
266 xtSmallInt, // smallint
267 xtShortInt, // shortint
268 xtByte, // byte
269 xtNativeInt, // depends on compiler and platform
270 xtNativeUInt, // depends on compiler and platform
271 xtCompilerFunc,// SUCC, PREC, LOW, HIGH, ORD, LENGTH, COPY (1.1), ...
272 xtVariant, // variant
273 xtJSValue, // jsvalue only in Pas2JS, similar to variant
274 xtNil // nil = pointer, class, procedure, method, ...
275 );
276 // Do not define: TExpressionTypeDescs = set of TExpressionTypeDesc;
277 // There are too many enums, so the set would be big and slow
278
279 var
280 ExpressionTypeDescNames: array[TExpressionTypeDesc] of string = (
281 'None',
282 'Context',
283 'Char',
284 'WideChar',
285 'Real',
286 'Single',
287 'Double',
288 'Extended',
289 'CExtended',
290 'Currency',
291 'Comp',
292 'Int64',
293 'Cardinal',
294 'QWord',
295 'Boolean',
296 'ByteBool',
297 'WordBool',
298 'LongBool',
299 'QWordBool',
300 'String',
301 'AnsiString',
302 'ShortString',
303 'WideString',
304 'UnicodeString',
305 'PChar',
306 'Pointer',
307 'File',
308 'TextFile',
309 'ConstOrdInt',
310 'ConstString',
311 'ConstReal',
312 'ConstSet',
313 'ConstBoolean',
314 'LongInt',
315 'LongWord',
316 'Word',
317 'SmallInt',
318 'ShortInt',
319 'Byte',
320 'NativeInt',
321 'NativeUInt',
322 'CompilerFunc',
323 'Variant',
324 'JSValue',
325 'Nil'
326 );
327
328 const
329 xtAllTypes = [Low(TExpressionTypeDesc)..High(TExpressionTypeDesc)]-[xtNone];
330 xtAllPredefinedTypes = xtAllTypes-[xtContext];
331 xtAllConstTypes = [xtConstOrdInteger,xtConstBoolean,xtConstReal,
332 xtConstString,xtConstSet,xtCompilerFunc,xtNil];
333 xtAllIdentTypes = xtAllTypes - xtAllConstTypes;
334 xtAllIdentPredefinedTypes = xtAllIdentTypes - [xtContext];
335 xtAllIntegerTypes = [xtInt64, xtQWord, xtConstOrdInteger, xtLongint,
336 xtLongWord, xtWord, xtCardinal, xtSmallInt, xtShortInt,
337 xtByte,xtNativeInt,xtNativeUInt];
338 xtAllBooleanTypes = [xtBoolean, xtByteBool, xtWordBool, xtLongBool,xtQWordBool];
339 xtAllRealTypes = [xtReal, xtConstReal, xtSingle, xtDouble,
340 xtExtended, xtCExtended, xtCurrency, xtComp];
341 xtAllStringTypes = [xtConstString, xtShortString, xtString, xtAnsiString];
342 xtAllWideStringTypes = [xtConstString, xtWideString, xtUnicodeString];
343 xtAllPointerTypes = [xtPointer, xtNil];
344 xtAllTypeHelperTypes = xtAllPredefinedTypes-[xtCompilerFunc,xtVariant,xtJSValue,xtNil];
345
346 xtAllStringCompatibleTypes = xtAllStringTypes+[xtChar,xtJSValue];
347 xtAllWideStringCompatibleTypes = xtAllWideStringTypes+[xtWideChar,xtChar];
348
349 xtAllIntegerConvertibles = xtAllIntegerTypes;
350 xtAllRealConvertibles = xtAllRealTypes+xtAllIntegerTypes;
351 xtAllStringConvertibles = xtAllStringCompatibleTypes+[xtPChar];
352 xtAllWideStringConvertibles = xtAllWideStringCompatibleTypes+[xtPChar];
353 xtAllBooleanConvertibles = xtAllBooleanTypes+[xtConstBoolean];
354 xtAllPointerConvertibles = xtAllPointerTypes+[xtPChar];
355 xtAllPas2JSExtraTypes = [xtJSValue,xtNativeInt,xtNativeUInt];
356
357 type
358 { TExpressionType is used for compatibility check
359 A compatibility check is done by comparing two TExpressionType
360
361 if Desc = xtConstSet, SubDesc contains the type of the set
362 if Context.Node<>nil, it contains the corresponding codetree node
363 if Desc = xtPointer then SubDesc contains the type e.g. xtChar
364 }
365 TExpressionType = record
366 Desc: TExpressionTypeDesc;
367 SubDesc: TExpressionTypeDesc;
368 Context: TFindContext;
369 end;
370 PExpressionType = ^TExpressionType;
371
372 const
373 CleanExpressionType : TExpressionType =
374 (Desc:xtNone; SubDesc:xtNone; Context:(Node:nil; Tool:nil));
375
376 type
377 //----------------------------------------------------------------------------
378 // TTypeCompatibility is the result of a compatibility check
379 TTypeCompatibility = (
380 tcExact, // exactly same type, can be used for var parameters
381 tcCompatible, // type can be auto converted, can not be used for var parameters
382 tcIncompatible // type is incompatible
383 );
384 TTypeCompatibilityList = ^TTypeCompatibility;
385
386 const
387 TypeCompatibilityNames: array[TTypeCompatibility] of string = (
388 'Exact',
389 'Compatible', // convertable, but not allowed for var params
390 'Incompatible'
391 );
392
393 type
394 //----------------------------------------------------------------------------
395 // TExprTypeList is used for compatibility checks of whole parameter lists
396 TExprTypeList = class
397 private
398 FCapacity: integer;
399 procedure SetCapacity(const AValue: integer);
400 protected
401 procedure Grow;
402 public
403 Count: integer;
404 Items: PExpressionType;
405 AliasTypes: PFindContext;
406 procedure Add(const ExprType: TExpressionType);
407 procedure Add(const ExprType: TExpressionType; const AliasType: TFindContext);
408 procedure AddFirst(const ExprType: TExpressionType);
409 property Capacity: integer read FCapacity write SetCapacity;
410 destructor Destroy; override;
AsStringnull411 function AsString: string;
CalcMemSizenull412 function CalcMemSize: PtrUInt;
413 end;
414
415 type
416
417 { TOperand }
418
419 TOperand = record
420 Expr: TExpressionType;
421 AliasType: TFindContext;
422 end;
423
424 //----------------------------------------------------------------------------
425 // TTypeAliasOrderList is used for comparing type aliases in binary operators
426
427 TTypeAliasItem = class
428 public
429 AliasName: string;
430 Position: Integer;
431 end;
432
433 TTypeAliasOrderList = class
434 private
435 FTree: TAVLTree;
436 public
437 constructor Create(const AliasNames: array of string);
438 destructor Destroy; override;
439
440 procedure Add(const AliasName: string);
441 procedure Add(const AliasNames: array of string);
442 procedure Insert(const AliasName: string; const Pos: Integer);
443 procedure InsertBefore(const AliasName, BeforeAlias: string);
444 procedure InsertAfter(const AliasName, AfterAlias: string);
445 procedure Delete(const Pos: Integer);
446 procedure Delete(const AliasName: string);
IndexOfnull447 function IndexOf(const AliasName: string): Integer;
Comparenull448 function Compare(const AliasName1, AliasName2: string): Integer;
Comparenull449 function Compare(const Operand1, Operand2: TOperand;
450 Tool: TFindDeclarationTool; CleanPos: Integer): TOperand;
451 end;
452
CompareTypeAliasItemsnull453 function CompareTypeAliasItems(Item1, Item2: Pointer): Integer;
CompareTypeAliasItemStringnull454 function CompareTypeAliasItemString(AliasName, Item: Pointer): Integer;
455
456 type
457 //----------------------------------------------------------------------------
458 // TFoundProc is used for comparing overloaded procs
459 PFoundProc = ^TFoundProc;
460 TFoundProc = record
461 // the expression input list, which should fit into the searched proc
462 ExprInputList: TExprTypeList;
463 // the best proc found till now
464 Context: TFindContext;
465 // if the proc was already compared (CacheValid=true), then some of the
466 // compatibility check results are cached.
467 CacheValid: boolean;
468 ProcCompatibility: TTypeCompatibility;
469 ParamCompatibilityList: TTypeCompatibilityList;
470 // each TFindDeclarationParams has a list of PFoundProc
471 Owner: TObject;
472 Next, Prior: PFoundProc;
473 end;
474
475 //---------------------------------------------------------------------------
476 type
477 TIdentifierFoundResult = (ifrProceedSearch, ifrAbortSearch, ifrSuccess);
478
479 const
480 IdentifierFoundResultNames: array[TIdentifierFoundResult] of string =
481 ('ProceedSearch', 'AbortSearch', 'Success');
482
483 type
aramsnull484 TOnIdentifierFound = function(Params: TFindDeclarationParams;
485 const FoundContext: TFindContext): TIdentifierFoundResult of object;
rcToolnull486 TOnFindUsedUnit = function(SrcTool: TFindDeclarationTool;
487 const TheUnitName, TheUnitInFilename: string): TCodeBuffer of object;
endernull488 TOnGetCodeToolForBuffer = function(Sender: TObject;
489 Code: TCodeBuffer; GoToMainCode: boolean): TFindDeclarationTool of object;
onstnull490 TOnGetDirectoryCache = function(const ADirectory: string
491 ): TCTDirectoryCache of object;
492
493 TFDHelpersListKind = (
494 fdhlkDelphiHelper,
495 fdhlkObjCCategory
496 );
497
498 { TFDHelpersListItem }
499
500 TFDHelpersListItem = class(TObject)
501 ForExprType: TExpressionType;
502 HelperContext: TFindContext; // Node.Desc (ctnClassHelper, ctnRecordHelper, ctnTypeHelper) or (ctnObjCCategory)
CalcMemSizenull503 function CalcMemSize: PtrUInt;
504 end;
505
506 { TFDHelpersListRec }
507
508 TFDHelpersListRec = record
509 ForExprType: TExpressionType;
510 HelperContext: TFindContext;
511 end;
512
513 { TFDHelpersList }
514
515 TFDHelpersList = class
516 private
517 FKind: TFDHelpersListKind;
518 FTree: TAVLTree; { tree of TFDHelpersListItem sorted for CompareHelpersList.
519 Nodes with same key (ForExprType) are chronologically ordered from left to right. }
520 procedure AddChronologically(Item: TFDHelpersListItem);
521 public
AddFromHelperNodenull522 function AddFromHelperNode(HelperNode: TCodeTreeNode;
523 Tool: TFindDeclarationTool; Replace: Boolean): TFDHelpersListItem;
524 procedure AddFromList(const ExtList: TFDHelpersList);
IterateFromClassNodenull525 function IterateFromClassNode(ClassNode: TCodeTreeNode;
526 Tool: TFindDeclarationTool; out HelperContext: TFindContext; out Iterator: TAVLTreeNode): boolean; // returns newest (rightmost)
GetNextnull527 function GetNext(out HelperContext: TFindContext; var Iterator: TAVLTreeNode): boolean;
FindFromExprTypenull528 function FindFromExprType(const ExprType: TExpressionType): TFindContext; // returns newest (rightmost)
529 procedure DeleteHelperNode(HelperNode: TCodeTreeNode; Tool: TFindDeclarationTool);
530 constructor Create(aKind: TFDHelpersListKind);
531 destructor Destroy; override;
532 procedure Clear;
Countnull533 function Count: Integer;
CalcMemSizenull534 function CalcMemSize: PtrUInt;
535 procedure WriteDebugReport;
536 property Kind: TFDHelpersListKind read FKind;
537 property Tree: TAVLTree read FTree;
538 end;
539
540 { TGenericParamValueMapping }
541
542 TGenericParamValueMapping = packed class
543 NextBrother: TGenericParamValueMapping;
544 GenericParamNode,
545 SpecializeValueNode: TCodeTreeNode;
546 constructor Create(pPrevBrother: TGenericParamValueMapping; pParam, pValue: TCodeTreeNode);
547 destructor Destroy; override;
548 end;
549
550 { TGenericParamValueMappings }
551
552 TGenericParamValueMappings = record
553 SpecializeParamsTool: TFindDeclarationTool;
554 SpecializeParamsNode: TCodeTreeNode;
555 SpecializeValuesTool: TFindDeclarationTool;
556 FirstParamValueMapping: TGenericParamValueMapping;
557 end;
558
559 { TGenericParams }
560
561 TGenericParams = record
562 ParamValuesTool: TFindDeclarationTool;
563 SpecializeParamsNode: TCodeTreeNode;
564 end;
565
566 TFindDeclarationInput = record
567 Flags: TFindDeclarationFlags;
568 Identifier: PChar;
569 ContextNode: TCodeTreeNode;
570 OnIdentifierFound: TOnIdentifierFound;
571 IdentifierTool: TFindDeclarationTool;
572 FoundProc: PFoundProc;
573 end;
574
575 { TFindDeclarationParams
576 This contains the parameters for find declaration, the result, the hooks
577 and the memory management for dynamic search data.
578 It can be re-used. That means, the search parameters can be saved, changed
579 and restored (load).
580 The static parameters are stored on the stack, while the dynamic data
581 (e.g. FoundProc) is stored in a private list (FirstFoundProc).
582 For speed reasons the find declaration does not use try..finally and that's
583 why some saved data is not explicitely freed. Therefore the Load method
584 frees all dynamic data, that was later saved too.
585 That's why the following code is forbidden:
586 Save(Data1);
587 Save(Data2);
588 Load(Data1); // this will free Data2
589 Load(Data2);
590
591 When searching a procedure, the parameter list must be compared.
592 The parameter list of the currently best fitting procedure is stored in
593 FoundProc.
594 }
595
596 TFindDeclarationParams = class(TObject)
597 private
598 FFoundProcStackFirst: PFoundProc;//list of all saved PFoundProc
599 FFoundProcStackLast: PFoundProc;
600 FExtractedOperand: string;
601 FHelpers: array[TFDHelpersListKind] of TFDHelpersList;
602 FFreeHelpers: array[TFDHelpersListKind] of Boolean;
603 FNeedHelpers: Boolean;
604 GenParamValueMappings: TGenericParamValueMappings;
605 procedure ClearFoundProc;
606 procedure FreeFoundProc(aFoundProc: PFoundProc; FreeNext: boolean);
607 procedure RemoveFoundProcFromList(aFoundProc: PFoundProc);
608 private
609 procedure SetFoundProc(const ProcContext: TFindContext);
610 procedure ChangeFoundProc(const ProcContext: TFindContext;
611 ProcCompatibility: TTypeCompatibility;
612 ParamCompatibilityList: TTypeCompatibilityList);
613 private
614 procedure SetGenericParamValues(SpecializeParamsTool: TFindDeclarationTool;
615 SpecializeNode: TCodeTreeNode);
616 procedure UpdateGenericParamMapping(SpecializeParamsTool: TFindDeclarationTool;
617 SpecializeParamsNode: TCodeTreeNode; GenericParamsNode: TCodeTreeNode);
618 procedure UpdateContexWithGenParamValue(var SpecializeParamContext: TFindContext);
FindGenericParamTypenull619 function FindGenericParamType: Boolean;
620 procedure AddOperandPart(aPart: string);
621 property ExtractedOperand: string read FExtractedOperand;
IsFoundProcFinalnull622 function IsFoundProcFinal: boolean;
623 procedure PrettifyResult;
624 procedure ConvertResultCleanPosToCaretPos;
625 procedure ClearResult(CopyCacheFlags: boolean);
626 procedure ClearInput;
627 public
628 // input parameters:
629 Flags: TFindDeclarationFlags;
630 Identifier: PChar;
631 StartTool: TFindDeclarationTool;
632 StartNode: TCodeTreeNode;
633 Parent: TFindDeclarationParams;
634 ContextNode: TCodeTreeNode;
635 OnIdentifierFound: TOnIdentifierFound;
636 IdentifierTool: TFindDeclarationTool;
637 FoundProc: PFoundProc;
638 Data: Pointer;
639 // global params
640 OnTopLvlIdentifierFound: TOnIdentifierFound;
641 GenParams: TGenericParams;
642 // results:
643 NewNode: TCodeTreeNode;
644 NewCleanPos: integer;
645 NewCodeTool: TFindDeclarationTool;
646 NewPos: TCodeXYPosition;
647 NewTopLine: integer;
648 NewFlags: TFoundDeclarationFlags;
649 constructor Create(ParentParams: TFindDeclarationParams = nil);
650 constructor Create(Tool: TFindDeclarationTool; AContextNode: TCodeTreeNode);
651 destructor Destroy; override;
652 procedure Clear;
653 procedure Save(out Input: TFindDeclarationInput);
654 procedure Load(Input: TFindDeclarationInput; FreeInput: boolean);
655 procedure SetResult(const AFindContext: TFindContext);
656 procedure SetResult(ANewCodeTool: TFindDeclarationTool;
657 ANewNode: TCodeTreeNode);
658 procedure SetResult(ANewCodeTool: TFindDeclarationTool;
659 ANewNode: TCodeTreeNode; ANewCleanPos: integer);
660 procedure SetResult(NodeCacheEntry: PCodeTreeNodeCacheEntry);
661 procedure SetIdentifier(NewIdentifierTool: TFindDeclarationTool;
662 NewIdentifier: PChar; NewOnIdentifierFound: TOnIdentifierFound);
663 procedure WriteDebugReport;
GetHelpersnull664 function GetHelpers(HelperKind: TFDHelpersListKind; CreateIfNotExists: boolean = false): TFDHelpersList;
665 end;
666
667
668 //----------------------------------------------------------------------------
669 // TFindDeclarationTool is source based and can therefore search for more
670 // than declarations:
671 type
672 TFindSmartFlag = (
673 fsfIncludeDirective, // search for include file
674 fsfFindMainDeclaration, // stop if already on a declaration
675 fsfSearchSourceName, // if searching for a unit name, return the source name node
676 fsfSkipClassForward // when a forward class was found, jump further to the class
677 );
678 TFindSmartFlags = set of TFindSmartFlag;
679 const
680 DefaultFindSmartFlags = [fsfIncludeDirective];
681 DefaultFindSmartHintFlags = DefaultFindSmartFlags+[fsfFindMainDeclaration];
682
683 type
684 TFindSrcStartType = (
685 fsstIdentifier
686 );
687
688 TFindDeclarationListFlag = (
689 fdlfWithoutEmptyProperties, // omit properties without type and attributes
690 fdlfWithoutForwards, // omit foward classes and procedures
691 fdlfIfStartIsDefinitionStop,// omit overloads when start is a definition
692 fdlfOneOverloadPerUnit // ignore other overloads of an identifier within the same unit
693 );
694 TFindDeclarationListFlags = set of TFindDeclarationListFlag;
695
696 TFindOperatorEnumerator = (
697 foeProcNode, // proc node of operator
698 foeResultClassNode, // classnode of result type of operator
ornull699 foeEnumeratorCurrentNode, // function or property with modifier 'enumerator Current'
700 foeEnumeratorCurrentExprType // expression type of 'enumerator Current'
701 );
702
703 TFindFileAtCursorFlag = (
704 ffatNone,
705 ffatUsedUnit,
706 ffatIncludeFile,
707 ffatDisabledIncludeFile,
708 ffatResource,
709 ffatDisabledResource,
710 ffatLiteral,
711 ffatComment,
712 ffatUnit // unit by name
713 );
714 TFindFileAtCursorFlags = set of TFindFileAtCursorFlag;
715 const
716 DefaultFindFileAtCursorAllowed = [Low(TFindFileAtCursorFlag)..high(TFindFileAtCursorFlag)];
717
718 type
719 //----------------------------------------------------------------------------
720 ECodeToolUnitNotFound = class(ECodeToolFileNotFound)
721 end;
722
723 //----------------------------------------------------------------------------
724
725 TFindIdentifierInUsesSection_FindMissingFPCUnit = class;
726
727 //----------------------------------------------------------------------------
728
729 { TFindDeclarationTool }
730
731 TFindDeclarationTool = class(TPascalReaderTool)
732 private
733 FAdjustTopLineDueToComment: boolean;
734 FDirectoryCache: TCTDirectoryCache;
735 FFindMissingFPCUnits: TFindIdentifierInUsesSection_FindMissingFPCUnit;
736 FInterfaceIdentifierCache: TInterfaceIdentifierCache;
737 FInterfaceHelperCache: array[TFDHelpersListKind] of TFDHelpersList;
738 FOnFindUsedUnit: TOnFindUsedUnit;
739 FOnGetCodeToolForBuffer: TOnGetCodeToolForBuffer;
740 FOnGetDirectoryCache: TOnGetDirectoryCache;
741 FOnGetMethodName: TOnGetMethodname;
742 FOnGetSrcPathForCompiledUnit: TOnGetSrcPathForCompiledUnit;
743 FOnGetUnitSourceSearchPath: TOnGetSearchPath;
744 FFirstNodeCache: TCodeTreeNodeCache;
745 FOnRescanFPCDirectoryCache: TNotifyEvent;
746 FRootNodeCache: TCodeTreeNodeCache;
747 FFirstBaseTypeCache: TBaseTypeCache;
748 FDependentCodeTools: TAVLTree;// the codetools, that depend on this codetool
749 FDependsOnCodeTools: TAVLTree;// the codetools, that this codetool depends on
750 FClearingDependentNodeCaches: boolean;
751 FCheckingNodeCacheDependencies: boolean;
752 FSourcesChangeStep, FFilesChangeStep: int64;
753 FInitValuesChangeStep: integer;
754 {$IFDEF DebugPrefix}
755 DebugPrefix: string;
756 procedure IncPrefix;
757 procedure DecPrefix;
758 {$ENDIF}
FindDeclarationInUsesSectionnull759 function FindDeclarationInUsesSection(UsesNode: TCodeTreeNode;
760 CleanPos: integer;
761 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
FindUnitFileInUsesSectionnull762 function FindUnitFileInUsesSection(UsesNode: TCodeTreeNode;
763 const AFilename: string): TCodeTreeNode;
FindUnitFileInAllUsesSectionsnull764 function FindUnitFileInAllUsesSections(const AFilename: string;
765 CheckMain: boolean = true; CheckImplementation: boolean = true): TCodeTreeNode;
FindEnumInContextnull766 function FindEnumInContext(Params: TFindDeclarationParams): boolean;
767 // sub methods for FindIdentifierInContext
DoOnIdentifierFoundnull768 function DoOnIdentifierFound(Params: TFindDeclarationParams;
769 FoundNode: TCodeTreeNode): TIdentifierFoundResult;
FindIdentifierInProcContextnull770 function FindIdentifierInProcContext(ProcContextNode: TCodeTreeNode;
771 Params: TFindDeclarationParams): TIdentifierFoundResult;
FindIdentifierInClassOfMethodnull772 function FindIdentifierInClassOfMethod(ProcContextNode: TCodeTreeNode;
773 Params: TFindDeclarationParams): boolean;
FindIdentifierInWithVarContextnull774 function FindIdentifierInWithVarContext(WithVarNode: TCodeTreeNode;
775 Params: TFindDeclarationParams): boolean;
FindIdentifierInAncestorsnull776 function FindIdentifierInAncestors(ClassNode: TCodeTreeNode;
777 Params: TFindDeclarationParams; var IdentFoundResult: TIdentifierFoundResult): boolean;
FindIdentifierInAncestorsnull778 function FindIdentifierInAncestors(ClassNode: TCodeTreeNode;
779 Params: TFindDeclarationParams): boolean;
FindIdentifierInUsesSectionnull780 function FindIdentifierInUsesSection(UsesNode: TCodeTreeNode;
781 Params: TFindDeclarationParams; FindMissingFPCUnits: Boolean): boolean;
FindIdentifierInHiddenUsedUnitsnull782 function FindIdentifierInHiddenUsedUnits(
783 Params: TFindDeclarationParams): boolean;
FindIdentifierInUsedUnitnull784 function FindIdentifierInUsedUnit(const AnUnitName: string;
785 Params: TFindDeclarationParams; ErrorPos: integer): boolean;
FindIdentifierInTypeOfConstantnull786 function FindIdentifierInTypeOfConstant(VarConstNode: TCodeTreeNode;
787 Params: TFindDeclarationParams): boolean;
788 protected
789 WordIsPredefinedIdentifier: TKeyWordFunctionList;
790 procedure RaiseUsesExpected(id: int64);
791 procedure RaiseStrConstExpected(id: int64);
792 protected
793 // node caches
794 procedure DoDeleteNodes(StartNode: TCodeTreeNode); override;
CheckDependsOnNodeCachesnull795 function CheckDependsOnNodeCaches(CheckedTools: TAVLTree = nil): boolean;
796 procedure ClearNodeCaches;
797 procedure ClearDependentNodeCaches;
798 procedure ClearDependsOnToolRelationships;
799 procedure AddToolDependency(DependOnTool: TFindDeclarationTool);
CreateNewNodeCachenull800 function CreateNewNodeCache(Node: TCodeTreeNode): TCodeTreeNodeCache;
CreateNewBaseTypeCachenull801 function CreateNewBaseTypeCache(Tool: TFindDeclarationTool;
802 Node: TCodeTreeNode): TBaseTypeCache;
803 procedure CreateBaseTypeCaches(NodeStack: PCodeTreeNodeStack;
804 const Result: TFindContext);
GetNodeCachenull805 function GetNodeCache(Node: TCodeTreeNode;
806 CreateIfNotExists: boolean): TCodeTreeNodeCache;
807 procedure AddResultToNodeCaches(
808 StartNode, EndNode: TCodeTreeNode; SearchedForward: boolean;
809 Params: TFindDeclarationParams; SearchRangeFlags: TNodeCacheEntryFlags);
810 protected
811 // expressions, operands, variables
GetCurrentAtomTypenull812 function GetCurrentAtomType: TVariableAtomType;
FindEndOfTermnull813 function FindEndOfTerm(StartPos: integer;
814 ExceptionIfNoVariableStart, WithAsOperator: boolean): integer; // read one operand
FindStartOfTermnull815 function FindStartOfTerm(EndPos: integer; InType: boolean): integer;
NodeTermInTypenull816 function NodeTermInType(Node: TCodeTreeNode): boolean;
FindExpressionTypeOfTermnull817 function FindExpressionTypeOfTerm(StartPos, EndPos: integer;
818 Params: TFindDeclarationParams; WithAsOperator: boolean;
819 AliasType: PFindContext = nil): TExpressionType;
FindEndOfExpressionnull820 function FindEndOfExpression(StartPos: integer): integer; // read all operands and operators
ReadOperandTypeAtCursornull821 function ReadOperandTypeAtCursor(Params: TFindDeclarationParams;
822 MaxEndPos: integer = -1; AliasType: PFindContext = nil): TExpressionType;
FindExpressionTypeOfPredefinedIdentifiernull823 function FindExpressionTypeOfPredefinedIdentifier(StartPos: integer;
824 Params: TFindDeclarationParams; AliasType: PFindContext = nil): TExpressionType;
FindExpressionTypeOfConstSetnull825 function FindExpressionTypeOfConstSet(Node: TCodeTreeNode): TExpressionType;
GetDefaultStringTypenull826 function GetDefaultStringType: TExpressionTypeDesc;
CalculateBinaryOperatornull827 function CalculateBinaryOperator(LeftOperand, RightOperand: TOperand;
828 BinaryOperator: TAtomPosition;
829 Params: TFindDeclarationParams): TOperand;
GetParameterNodenull830 function GetParameterNode(Node: TCodeTreeNode): TCodeTreeNode;
GetExpressionTypeOfTypeIdentifiernull831 function GetExpressionTypeOfTypeIdentifier(
832 Params: TFindDeclarationParams): TExpressionType;
FindTermTypeAsStringnull833 function FindTermTypeAsString(TermPos: TAtomPosition;
834 Params: TFindDeclarationParams; out ExprType: TExpressionType): string;
FindForInTypeAsStringnull835 function FindForInTypeAsString(TermPos: TAtomPosition;
836 CursorNode: TCodeTreeNode; Params: TFindDeclarationParams;
837 out ExprType: TExpressionType): string;
FindEnumeratorOfClassnull838 function FindEnumeratorOfClass(ClassNode: TCodeTreeNode;
839 ExceptionOnNotFound: boolean; out ExprType: TExpressionType;
840 AliasType: PFindContext = nil; ParentParams: TFindDeclarationParams = nil): boolean;
FindOperatorEnumeratornull841 function FindOperatorEnumerator(Node: TCodeTreeNode;
842 ExprType: TExpressionType; Need: TFindOperatorEnumerator;
843 out ResultExprType: TExpressionType): boolean;
FindEnumerationTypeOfSetTypenull844 function FindEnumerationTypeOfSetType(SetTypeNode: TCodeTreeNode;
845 out Context: TFindContext): boolean;
FindElementTypeOfArrayTypenull846 function FindElementTypeOfArrayType(ArrayNode: TCodeTreeNode;
847 out ExprType: TExpressionType; AliasType: PFindContext;
848 ParentParams: TFindDeclarationParams = nil): boolean;
CheckOperatorEnumeratornull849 function CheckOperatorEnumerator(Params: TFindDeclarationParams;
850 const FoundContext: TFindContext): TIdentifierFoundResult;
CheckModifierEnumeratorCurrentnull851 function CheckModifierEnumeratorCurrent({%H-}Params: TFindDeclarationParams;
852 const FoundContext: TFindContext): TIdentifierFoundResult;
IsTermEdgedBracketnull853 function IsTermEdgedBracket(TermPos: TAtomPosition;
854 out EdgedBracketsStartPos: integer): boolean;
IsTermNamedPointernull855 function IsTermNamedPointer(TermPos: TAtomPosition;
856 out ExprType: TExpressionType): boolean;
FindSetOfEnumerationTypenull857 function FindSetOfEnumerationType(EnumNode: TCodeTreeNode): TCodeTreeNode;
FindPointerOfIdentifiernull858 function FindPointerOfIdentifier(TypeNode: TCodeTreeNode): TCodeTreeNode;
FindExprTypeAsStringnull859 function FindExprTypeAsString(const ExprType: TExpressionType;
860 TermCleanPos: integer;
861 AliasType: PFindContext = nil): string;
862 protected
CheckSrcIdentifiernull863 function CheckSrcIdentifier(Params: TFindDeclarationParams;
864 const FoundContext: TFindContext): TIdentifierFoundResult;
FindDeclarationOfIdentAtParamnull865 function FindDeclarationOfIdentAtParam(
866 Params: TFindDeclarationParams; out ExprType: TExpressionType): boolean;
FindDeclarationOfIdentAtParamnull867 function FindDeclarationOfIdentAtParam(
868 Params: TFindDeclarationParams): boolean;
IdentifierIsDefinednull869 function IdentifierIsDefined(const IdentAtom: TAtomPosition;
870 ContextNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean;
FindContextNodeAtCursornull871 function FindContextNodeAtCursor(
872 Params: TFindDeclarationParams): TFindContext;
FindClassOfMethodnull873 function FindClassOfMethod(ProcNode: TCodeTreeNode;
874 FindClassContext, ExceptionOnNotFound: boolean): TCodeTreeNode;
FindClassMembernull875 function FindClassMember(aClassNode: TCodeTreeNode; Identifier: PChar): TCodeTreeNode;
FindForwardIdentifiernull876 function FindForwardIdentifier(Params: TFindDeclarationParams;
877 out IsForward: boolean): boolean;
FindNonForwardClassnull878 function FindNonForwardClass(ForwardNode: TCodeTreeNode): TCodeTreeNode;
FindNonForwardClassnull879 function FindNonForwardClass(Params: TFindDeclarationParams): boolean;
FindIdentifierInInterfacenull880 function FindIdentifierInInterface(AskingTool: TFindDeclarationTool;
881 Params: TFindDeclarationParams): boolean;
CompareNodeIdentifiernull882 function CompareNodeIdentifier(Node: TCodeTreeNode;
883 Params: TFindDeclarationParams): boolean;
GetInterfaceNodenull884 function GetInterfaceNode: TCodeTreeNode;
CompatibilityList1IsBetternull885 function CompatibilityList1IsBetter(List1, List2: TTypeCompatibilityList;
886 ListCount: integer): boolean;
IsParamExprListCompatibleToNodeListnull887 function IsParamExprListCompatibleToNodeList(
888 FirstTargetParameterNode: TCodeTreeNode;
889 SourceExprParamList: TExprTypeList; IgnoreMissingParameters: boolean;
890 Params: TFindDeclarationParams;
891 CompatibilityList: TTypeCompatibilityList): TTypeCompatibility;
IsParamNodeListCompatibleToParamNodeListnull892 function IsParamNodeListCompatibleToParamNodeList(FirstTargetParameterNode,
893 FirstSourceParameterNode: TCodeTreeNode;
894 Params: TFindDeclarationParams;
895 CompatibilityList: TTypeCompatibilityList): TTypeCompatibility;
CreateParamExprListFromStatementnull896 function CreateParamExprListFromStatement(StartPos: integer;
897 Params: TFindDeclarationParams; GetAlias: boolean = false): TExprTypeList;
ContextIsDescendOfnull898 function ContextIsDescendOf(
899 const DescendContext, AncestorContext: TFindContext;
900 Params: TFindDeclarationParams): boolean;
IsCompatiblenull901 function IsCompatible(TargetNode: TCodeTreeNode;
902 const ExpressionType: TExpressionType;
903 Params: TFindDeclarationParams): TTypeCompatibility;
IsCompatiblenull904 function IsCompatible(TargetType, ExpressionType: TExpressionType;
905 Params: TFindDeclarationParams): TTypeCompatibility;
IsBaseCompatiblenull906 function IsBaseCompatible(const TargetType, ExpressionType: TExpressionType;
907 Params: TFindDeclarationParams): TTypeCompatibility;
CheckParameterSyntaxnull908 function CheckParameterSyntax(StartPos, CleanCursorPos: integer;
909 out ParameterAtom, ProcNameAtom: TAtomPosition;
910 out ParameterIndex: integer): boolean;
911 procedure OnFindUsedUnitIdentifier(Sender: TPascalParserTool;
912 IdentifierCleanPos: integer; Range: TEPRIRange;
913 Node: TCodeTreeNode; Data: Pointer; var {%H-}Abort: boolean);
914 public
915 constructor Create;
916 destructor Destroy; override;
917 procedure ConsistencyCheck; override;
918 procedure CalcMemSize(Stats: TCTMemStats); override;
919
920 procedure BeginParsing(Range: TLinkScannerRange); override;
921 procedure ValidateToolDependencies; override;
BuildInterfaceIdentifierCachenull922 function BuildInterfaceIdentifierCache(ExceptionOnNotUnit: boolean): boolean;
FindDeclarationnull923 function FindDeclaration(const CursorPos: TCodeXYPosition;
924 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
FindMainDeclarationnull925 function FindMainDeclaration(const CursorPos: TCodeXYPosition;
926 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
FindDeclarationOfIdentifiernull927 function FindDeclarationOfIdentifier(const CursorPos: TCodeXYPosition;
928 Identifier: PChar;
929 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
FindDeclarationnull930 function FindDeclaration(const CursorPos: TCodeXYPosition;
931 SearchSmartFlags: TFindSmartFlags;
932 out NewTool: TFindDeclarationTool; out NewNode: TCodeTreeNode;
933 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
FindDeclarationnull934 function FindDeclaration(const CursorPos: TCodeXYPosition;
935 SearchSmartFlags: TFindSmartFlags;
936 out NewTool: TFindDeclarationTool; out NewNode: TCodeTreeNode;
937 out NewPos: TCodeXYPosition; out NewTopLine, BlockTopLine, BlockBottomLine: integer): boolean;
FindDeclarationnull938 function FindDeclaration(const CursorPos: TCodeXYPosition;
939 SearchSmartFlags: TFindSmartFlags;
940 out NewExprType: TExpressionType;
941 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
FindDeclarationnull942 function FindDeclaration(const CursorPos: TCodeXYPosition;
943 SearchSmartFlags: TFindSmartFlags;
944 out NewExprType: TExpressionType;
945 out NewPos: TCodeXYPosition; out NewTopLine,BlockTopLine,BlockBottomLine: integer): boolean;
FindDeclarationInInterfacenull946 function FindDeclarationInInterface(const Identifier: string;
947 out NewPos: TCodeXYPosition; out NewTopLine, BlockTopLine, BlockBottomLine: integer): boolean;
FindDeclarationWithMainUsesSectionnull948 function FindDeclarationWithMainUsesSection(const Identifier: string;
949 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
FindClassMembernull950 function FindClassMember(aClassNode: TCodeTreeNode;
951 const Identifier: String; SearchInAncestors: boolean): TFindContext;
FindDeclarationOfPropertyPathnull952 function FindDeclarationOfPropertyPath(const PropertyPath: string;
953 out NewContext: TFindContext; IgnoreTypeLess: boolean = false): boolean;
FindDeclarationOfPropertyPathnull954 function FindDeclarationOfPropertyPath(const PropertyPath: string;
955 out NewPos: TCodeXYPosition; out NewTopLine: integer;
956 IgnoreTypeLess: boolean = false): boolean;
FindDeclarationNodeInInterfacenull957 function FindDeclarationNodeInInterface(const Identifier: string;
958 BuildTheTree: Boolean): TCodeTreeNode;// search for type, const, var, proc, prop
FindDeclarationNodeInImplementationnull959 function FindDeclarationNodeInImplementation(Identifier: string;
960 BuildTheTree: Boolean): TCodeTreeNode;// search for type, const, var, proc, prop
FindSubDeclarationnull961 function FindSubDeclaration(Identifier: string; ParentNode: TCodeTreeNode
962 ): TCodeTreeNode; // search for type, const, var, proc, prop
FindNameInUsesSectionnull963 function FindNameInUsesSection(UsesNode: TCodeTreeNode; const AUnitName: string): TCodeTreeNode;
FindUnitInUsesSectionnull964 function FindUnitInUsesSection(UsesNode: TCodeTreeNode; const AnUnitName: string;
965 out NamePos, InPos: TAtomPosition): boolean;
FindUnitInAllUsesSectionsnull966 function FindUnitInAllUsesSections(const AnUnitName: string;
967 out NamePos, InPos: TAtomPosition): boolean;
GetUnitNameForUsesSectionnull968 function GetUnitNameForUsesSection(TargetTool: TFindDeclarationTool): string;
IsHiddenUsedUnitnull969 function IsHiddenUsedUnit(TheUnitName: PChar): boolean;
970
FindCodeToolForUsedUnitnull971 function FindCodeToolForUsedUnit(const AnUnitName, AnUnitInFilename: string;
972 ExceptionOnNotFound: boolean): TFindDeclarationTool;
FindUnitSourcenull973 function FindUnitSource(const AnUnitName,
974 AnUnitInFilename: string; ExceptionOnNotFound: boolean;
975 ErrorPos: integer = 0): TCodeBuffer;
FindUnitCaseInsensitivenull976 function FindUnitCaseInsensitive(var AnUnitName,
977 AnUnitInFilename: string): string;
978 procedure GatherUnitAndSrcPath(var UnitPath, CompleteSrcPath: string);
SearchUnitInUnitSetnull979 function SearchUnitInUnitSet(const TheUnitName: string): string;
GetNameSpacesnull980 function GetNameSpaces: string;
981
IsIncludeDirectiveAtPosnull982 function IsIncludeDirectiveAtPos(CleanPos, CleanCodePosInFront: integer;
983 out IncludeCode: TCodeBuffer): boolean;
FindFileAtCursornull984 function FindFileAtCursor(const CursorPos: TCodeXYPosition;
985 out Found: TFindFileAtCursorFlag; out FoundFilename: string;
986 SearchFor: TFindFileAtCursorFlags = DefaultFindFileAtCursorAllowed;
987 StartPos: PCodeXYPosition = nil): boolean;
988
FindSmartHintnull989 function FindSmartHint(const CursorPos: TCodeXYPosition;
990 Flags: TFindSmartFlags = DefaultFindSmartHintFlags): string;
GetSmartHintnull991 function GetSmartHint(Node: TCodeTreeNode; XYPos: TCodeXYPosition;
992 WithPosition: boolean; WithDefinition: boolean = True): string;
993
BaseTypeOfNodeHasSubIdentsnull994 function BaseTypeOfNodeHasSubIdents(ANode: TCodeTreeNode): boolean;
FindBaseTypeOfNodenull995 function FindBaseTypeOfNode(Params: TFindDeclarationParams;
996 Node: TCodeTreeNode; AliasType: PFindContext = nil;
997 NodeStack: PCodeTreeNodeStack = nil): TFindContext;
ConvertNodeToExpressionTypenull998 function ConvertNodeToExpressionType(Node: TCodeTreeNode;
999 Params: TFindDeclarationParams; AliasType: PFindContext = nil): TExpressionType;
FindExpressionResultTypenull1000 function FindExpressionResultType(Params: TFindDeclarationParams;
1001 StartPos, EndPos: integer; AliasType: PFindContext = nil): TExpressionType;
1002
FindDeclarationAndOverloadnull1003 function FindDeclarationAndOverload(const CursorPos: TCodeXYPosition;
1004 out ListOfPCodeXYPosition: TFPList;
1005 Flags: TFindDeclarationListFlags): boolean;
FindIdentifierContextsAtStatementnull1006 function FindIdentifierContextsAtStatement(CleanPos: integer;
1007 out IsSubIdentifier: boolean; out ListOfPFindContext: TFPList): boolean;
1008
1009 // ancestors
FindClassAndAncestorsnull1010 function FindClassAndAncestors(ClassNode: TCodeTreeNode;
1011 var ListOfPFindContext: TFPList; ExceptionOnNotFound: boolean
1012 ): boolean; // without interfaces, recursive
FindContextClassAndAncestorsAndExtendedClassOfHelpernull1013 function FindContextClassAndAncestorsAndExtendedClassOfHelper(const CursorPos: TCodeXYPosition;
1014 var ListOfPFindContext: TFPList): boolean; // without interfaces
FindAncestorOfClassnull1015 function FindAncestorOfClass(ClassNode: TCodeTreeNode;
1016 Params: TFindDeclarationParams; FindClassContext: boolean): boolean; // returns false for TObject, IInterface, IUnknown
FindDefaultAncestorOfClassnull1017 function FindDefaultAncestorOfClass(ClassNode: TCodeTreeNode;
1018 Params: TFindDeclarationParams; FindClassContext: boolean): boolean; // returns false for TObject, IInterface, IUnknown
FindAncestorOfClassInheritancenull1019 function FindAncestorOfClassInheritance(IdentifierNode: TCodeTreeNode;
1020 ResultParams: TFindDeclarationParams; FindClassContext: boolean): boolean;
FindAncestorsOfClassnull1021 function FindAncestorsOfClass(ClassNode: TCodeTreeNode;
1022 var ListOfPFindContext: TFPList;
1023 Params: TFindDeclarationParams; FindClassContext: boolean;
1024 ExceptionOnNotFound: boolean = true): boolean; // with interfaces, not recursive
1025
FindExtendedExprOfHelpernull1026 function FindExtendedExprOfHelper(HelperNode: TCodeTreeNode): TExpressionType;
1027
FindReferencesnull1028 function FindReferences(const CursorPos: TCodeXYPosition;
1029 SkipComments: boolean; out ListOfPCodeXYPosition: TFPList): boolean;
FindUnitReferencesnull1030 function FindUnitReferences(UnitCode: TCodeBuffer;
1031 SkipComments: boolean; out ListOfPCodeXYPosition: TFPList): boolean; // searches unitname of UnitCode
1032 procedure FindUsedUnitReferences(const CursorPos: TCodeXYPosition;
1033 SkipComments: boolean; out UsedUnitFilename: string;
1034 out ListOfPCodeXYPosition: TFPList); // searches all references of unit in uses clause
1035 procedure FindUsedUnitReferences(TargetTool: TFindDeclarationTool;
1036 SkipComments: boolean;
1037 out ListOfPCodeXYPosition: TFPList); // searches all references of TargetTool
1038
CleanPosIsDeclarationIdentifiernull1039 function CleanPosIsDeclarationIdentifier(CleanPos: integer;
1040 Node: TCodeTreeNode): boolean;
1041
1042 procedure FindHelpersInContext(Params: TFindDeclarationParams);
1043 procedure FindHelpersInUsesSection(UsesNode: TCodeTreeNode;
1044 Params: TFindDeclarationParams);
1045 procedure FindHelpersInInterface(AskingTool: TFindDeclarationTool;
1046 Params: TFindDeclarationParams);
FindIdentifierInContextnull1047 function FindIdentifierInContext(Params: TFindDeclarationParams;
1048 var IdentFoundResult: TIdentifierFoundResult): boolean;
FindIdentifierInContextnull1049 function FindIdentifierInContext(Params: TFindDeclarationParams): boolean;
FindIdentifierInBasicTypeHelpersnull1050 function FindIdentifierInBasicTypeHelpers(ExprType: TExpressionTypeDesc;
1051 Params: TFindDeclarationParams): Boolean;
FindNthParameterNodenull1052 function FindNthParameterNode(Node: TCodeTreeNode;
1053 ParameterIndex: integer): TCodeTreeNode;
GetFirstParameterNodenull1054 function GetFirstParameterNode(Node: TCodeTreeNode): TCodeTreeNode;
IsParamNodeListCompatibleToExprListnull1055 function IsParamNodeListCompatibleToExprList(
1056 TargetExprParamList: TExprTypeList;
1057 FirstSourceParameterNode: TCodeTreeNode;
1058 Params: TFindDeclarationParams;
1059 CompatibilityList: TTypeCompatibilityList = nil): TTypeCompatibility;
CreateParamExprListFromProcNodenull1060 function CreateParamExprListFromProcNode(ProcNode: TCodeTreeNode;
1061 Params: TFindDeclarationParams): TExprTypeList;
1062
JumpToNodenull1063 function JumpToNode(ANode: TCodeTreeNode;
1064 out NewPos: TCodeXYPosition; out NewTopLine: integer;
1065 IsCodeBlock: boolean): boolean;
JumpToNodenull1066 function JumpToNode(ANode: TCodeTreeNode;
1067 out NewPos: TCodeXYPosition; out NewTopLine, BlockTopLine, BlockBottomLine: integer;
1068 IsCodeBlock: boolean): boolean;
JumpToCleanPosnull1069 function JumpToCleanPos(NewCleanPos, NewTopLineCleanPos,
1070 NewBottomLineCleanPos: integer;
1071 out NewPos: TCodeXYPosition; out NewTopLine: integer;
1072 IsCodeBlock: boolean): boolean;
JumpToCleanPosnull1073 function JumpToCleanPos(NewCleanPos, NewTopLineCleanPos,
1074 NewBottomLineCleanPos: integer;
1075 out NewPos: TCodeXYPosition; out NewTopLine, BlockTopLine, BlockBottomLine: integer;
1076 IsCodeBlock: boolean): boolean;
NodeIsForwardDeclarationnull1077 function NodeIsForwardDeclaration(Node: TCodeTreeNode): boolean;
1078
GetExpandedOperandnull1079 function GetExpandedOperand(const CursorPos: TCodeXYPosition;
1080 out Operand: string; ResolveProperty: Boolean): Boolean;
1081
1082 property InterfaceIdentifierCache: TInterfaceIdentifierCache
1083 read FInterfaceIdentifierCache;
1084 property OnGetUnitSourceSearchPath: TOnGetSearchPath
1085 read FOnGetUnitSourceSearchPath write FOnGetUnitSourceSearchPath;
1086 property OnFindUsedUnit: TOnFindUsedUnit
1087 read FOnFindUsedUnit write FOnFindUsedUnit;
1088 property OnGetCodeToolForBuffer: TOnGetCodeToolForBuffer
1089 read FOnGetCodeToolForBuffer write FOnGetCodeToolForBuffer;
1090 property OnGetDirectoryCache: TOnGetDirectoryCache read FOnGetDirectoryCache
1091 write FOnGetDirectoryCache;
1092 property OnGetSrcPathForCompiledUnit: TOnGetSrcPathForCompiledUnit
1093 read FOnGetSrcPathForCompiledUnit write fOnGetSrcPathForCompiledUnit;
1094 property OnGetMethodName: TOnGetMethodname read FOnGetMethodName
1095 write FOnGetMethodName;
1096 property AdjustTopLineDueToComment: boolean
1097 read FAdjustTopLineDueToComment write FAdjustTopLineDueToComment;
1098 property DirectoryCache: TCTDirectoryCache read FDirectoryCache write FDirectoryCache;
1099
1100 property OnRescanFPCDirectoryCache: TNotifyEvent read FOnRescanFPCDirectoryCache write FOnRescanFPCDirectoryCache;
1101 end;
1102
1103 TFindIdentifierInUsesSection_FindMissingFPCUnit = class
1104 private
1105 FUnitName: string;
1106 FFound: Boolean;
1107 FResults: TStringList;
1108
1109 procedure Iterate(const AFilename: string);
1110 public
1111 constructor Create;
1112 destructor Destroy; override;
Findnull1113 function Find(const AUnitName: string; const ADirectoryCache: TCTDirectoryCache): Boolean;
IsInResultsnull1114 function IsInResults(const AUnitName: string): Boolean;
1115 end;
1116
ExprTypeToStringnull1117 function ExprTypeToString(const ExprType: TExpressionType): string;
CreateExpressionTypenull1118 function CreateExpressionType(const Desc, SubDesc: TExpressionTypeDesc;
1119 const Context: TFindContext): TExpressionType;
1120
FindContextToStringnull1121 function FindContextToString(const FindContext: TFindContext; RelativeFilename: boolean = true): string; overload;
FindContextToStringnull1122 function FindContextToString(const FindContext: PFindContext; RelativeFilename: boolean = true): string; overload;
CreateFindContextnull1123 function CreateFindContext(NewTool: TFindDeclarationTool;
1124 NewNode: TCodeTreeNode): TFindContext;
CreateFindContextnull1125 function CreateFindContext(Params: TFindDeclarationParams): TFindContext;
CreateFindContextnull1126 function CreateFindContext(BaseTypeCache: TBaseTypeCache): TFindContext;
FindContextAreEqualnull1127 function FindContextAreEqual(const Context1, Context2: TFindContext): boolean;
CompareFindContextsnull1128 function CompareFindContexts(const Context1, Context2: PFindContext): integer;
1129 procedure AddFindContext(var ListOfPFindContext: TFPList;
1130 const NewContext: TFindContext);
IndexOfFindContextnull1131 function IndexOfFindContext(var ListOfPFindContext: TFPList;
1132 const AContext: PFindContext): integer;
1133 procedure FreeListOfPFindContext(var ListOfPFindContext: TFPList);
1134
ListOfPFindContextToStrnull1135 function ListOfPFindContextToStr(const ListOfPFindContext: TFPList): string;
dbgsFCnull1136 function dbgsFC(const Context: TFindContext): string;
1137
PredefinedIdentToExprTypeDescnull1138 function PredefinedIdentToExprTypeDesc(Identifier: PChar; Compiler: TPascalCompiler): TExpressionTypeDesc;
dbgsnull1139 function dbgs(const Flags: TFindDeclarationFlags): string; overload;
dbgsnull1140 function dbgs(const Flags: TFoundDeclarationFlags): string; overload;
dbgsnull1141 function dbgs(const vat: TVariableAtomType): string; overload;
dbgsnull1142 function dbgs(const Kind: TFDHelpersListKind): string; overload;
1143
1144
BooleanTypesOrderListnull1145 function BooleanTypesOrderList: TTypeAliasOrderList;
IntegerTypesOrderListnull1146 function IntegerTypesOrderList: TTypeAliasOrderList;
RealTypesOrderListnull1147 function RealTypesOrderList: TTypeAliasOrderList;
StringTypesOrderListnull1148 function StringTypesOrderList: TTypeAliasOrderList;
1149
1150 implementation
1151
1152 var
1153 FBooleanTypesOrderList: TTypeAliasOrderList;
1154 FIntegerTypesOrderList: TTypeAliasOrderList;
1155 FRealTypesOrderList: TTypeAliasOrderList;
1156 FStringTypesOrderList: TTypeAliasOrderList;
1157
1158 type
1159
1160 { TFindUsedUnitReferences }
1161
1162 TFindUsedUnitReferences = class
1163 public
1164 TargetTool: TFindDeclarationTool;
1165 TargetUnitName: string;
1166 ListOfPCodeXYPosition: TFPList;
1167 Params: TFindDeclarationParams;
1168 constructor Create(Tool: TFindDeclarationTool; AContextNode: TCodeTreeNode);
1169 destructor Destroy; override;
1170 end;
1171
dbgsnull1172 function dbgs(const Flags: TFindDeclarationFlags): string;
1173 var
1174 Flag: TFindDeclarationFlag;
1175 s: string;
1176 begin
1177 Result:='';
1178 for Flag:=Low(TFindDeclarationFlag) to High(TFindDeclarationFlag) do begin
1179 if Flag in Flags then begin
1180 if Result<>'' then
1181 Result:=Result+', ';
1182 WriteStr(s, Flag);
1183 Result:=Result+s;
1184 end;
1185 end;
1186 end;
1187
dbgsnull1188 function dbgs(const Flags: TFoundDeclarationFlags): string;
1189 var
1190 Flag: TFoundDeclarationFlag;
1191 s: string;
1192 begin
1193 Result:='';
1194 for Flag:=Low(TFoundDeclarationFlag) to High(TFoundDeclarationFlag) do begin
1195 if Flag in Flags then begin
1196 if Result<>'' then
1197 Result:=Result+', ';
1198 WriteStr(s, Flag);
1199 Result:=Result+s;
1200 end;
1201 end;
1202 end;
1203
dbgsnull1204 function dbgs(const vat: TVariableAtomType): string;
1205 begin
1206 Result:=VariableAtomTypeNames[vat];
1207 end;
1208
dbgsnull1209 function dbgs(const Kind: TFDHelpersListKind): string;
1210 begin
1211 WriteStr(Result, Kind);
1212 end;
1213
BooleanTypesOrderListnull1214 function BooleanTypesOrderList: TTypeAliasOrderList;
1215 begin
1216 if FBooleanTypesOrderList=nil then
1217 FBooleanTypesOrderList:=TTypeAliasOrderList.Create([
1218 'LongBool', 'WordBool', 'Boolean', 'ByteBool']);
1219
1220 Result := FBooleanTypesOrderList;
1221 end;
1222
IntegerTypesOrderListnull1223 function IntegerTypesOrderList: TTypeAliasOrderList;
1224 begin
1225 if FIntegerTypesOrderList=nil then
1226 FIntegerTypesOrderList:=TTypeAliasOrderList.Create([
1227 'Int64', 'QWord',
1228 'NativeInt', 'IntPtr', 'SizeInt', 'NativeUInt', 'UIntPtr',
1229 'Int32', 'Integer', 'LongInt', 'UInt32', 'Cardinal', 'LongWord',
1230 'Int16', 'SmallInt', 'UInt16', 'Word',
1231 'Int8', 'ShortInt', 'UInt8', 'Byte']);
1232
1233 Result := FIntegerTypesOrderList;
1234 end;
1235
RealTypesOrderListnull1236 function RealTypesOrderList: TTypeAliasOrderList;
1237 begin
1238 if FRealTypesOrderList=nil then
1239 FRealTypesOrderList:=TTypeAliasOrderList.Create([
1240 'Extended', 'Real', 'Double', 'Single']);
1241
1242 Result := FRealTypesOrderList;
1243 end;
1244
StringTypesOrderListnull1245 function StringTypesOrderList: TTypeAliasOrderList;
1246 begin
1247 if FStringTypesOrderList=nil then
1248 FStringTypesOrderList:=TTypeAliasOrderList.Create([
1249 'string', 'AnsiString', 'WideString', 'ShortString', 'Char', 'WideChar', 'AnsiChar']);
1250
1251 Result := FStringTypesOrderList;
1252 end;
1253
ListOfPFindContextToStrnull1254 function ListOfPFindContextToStr(const ListOfPFindContext: TFPList): string;
1255 var
1256 Context: TFindContext;
1257 i: Integer;
1258 begin
1259 if ListOfPFindContext=nil then
1260 Result:='nil'
1261 else begin
1262 Result:='';
1263 for i:=0 to ListOfPFindContext.Count-1 do begin
1264 Context:=PFindContext(ListOfPFindContext[i])^;
1265 Result:=Result+' '+DbgsFC(Context)+LineEnding;
1266 end;
1267 end;
1268 end;
1269
dbgsFCnull1270 function dbgsFC(const Context: TFindContext): string;
1271 var
1272 CursorPos: TCodeXYPosition;
1273 begin
1274 if Context.Tool=nil then
1275 Result:='nil'
1276 else begin
1277 Result:=Context.Tool.MainFilename;
1278 if Context.Node=nil then
1279 Result:=Result+'()'
1280 else begin
1281 Context.Tool.CleanPosToCaret(Context.Node.StartPos,CursorPos);
1282 Result:=Result+'(y='+dbgs(CursorPos.Y)+',x='+dbgs(CursorPos.X)+')';
1283 end;
1284 end;
1285 end;
1286
PredefinedIdentToExprTypeDescnull1287 function PredefinedIdentToExprTypeDesc(Identifier: PChar;
1288 Compiler: TPascalCompiler): TExpressionTypeDesc;
1289 begin
1290 // predefined identifiers
1291 if CompareIdentifiers(Identifier,'NIL')=0 then
1292 Result:=xtNil
1293 else if CompareIdentifiers(Identifier,'POINTER')=0 then
1294 Result:=xtPointer
1295 else if (CompareIdentifiers(Identifier,'TRUE')=0)
1296 or (CompareIdentifiers(Identifier,'FALSE')=0) then
1297 Result:=xtConstBoolean
1298 else if CompareIdentifiers(Identifier,'STRING')=0 then
1299 Result:=xtString
1300 else if CompareIdentifiers(Identifier,'SHORTSTRING')=0 then
1301 Result:=xtShortString
1302 else if CompareIdentifiers(Identifier,'ANSISTRING')=0 then
1303 Result:=xtAnsiString
1304 else if CompareIdentifiers(Identifier,'WIDESTRING')=0 then
1305 Result:=xtWideString
1306 else if CompareIdentifiers(Identifier,'UNICODESTRING')=0 then
1307 Result:=xtUnicodeString
1308 else if CompareIdentifiers(Identifier,'INT64')=0 then
1309 Result:=xtInt64
1310 else if CompareIdentifiers(Identifier,'CARDINAL')=0 then
1311 Result:=xtCardinal
1312 else if CompareIdentifiers(Identifier,'QWORD')=0 then
1313 Result:=xtQWord
1314 else if CompareIdentifiers(Identifier,'BOOLEAN')=0 then
1315 Result:=xtBoolean
1316 else if CompareIdentifiers(Identifier,'BYTEBOOL')=0 then
1317 Result:=xtByteBool
1318 else if CompareIdentifiers(Identifier,'WORDBOOL')=0 then
1319 Result:=xtWordBool
1320 else if CompareIdentifiers(Identifier,'LONGBOOL')=0 then
1321 Result:=xtLongBool
1322 else if CompareIdentifiers(Identifier,'QWORDBOOL')=0 then
1323 Result:=xtQWordBool
1324 else if CompareIdentifiers(Identifier,'CHAR')=0 then
1325 Result:=xtChar
1326 else if CompareIdentifiers(Identifier,'WIDECHAR')=0 then
1327 Result:=xtWideChar
1328 else if CompareIdentifiers(Identifier,'REAL')=0 then
1329 Result:=xtReal
1330 else if CompareIdentifiers(Identifier,'SINGLE')=0 then
1331 Result:=xtSingle
1332 else if CompareIdentifiers(Identifier,'DOUBLE')=0 then
1333 Result:=xtDouble
1334 else if CompareIdentifiers(Identifier,'EXTENDED')=0 then
1335 Result:=xtExtended
1336 else if CompareIdentifiers(Identifier,'CEXTENDED')=0 then
1337 Result:=xtCExtended
1338 else if CompareIdentifiers(Identifier,'COMP')=0 then
1339 Result:=xtComp
1340 else if CompareIdentifiers(Identifier,'FILE')=0 then
1341 Result:=xtFile
1342 else if CompareIdentifiers(Identifier,'TEXT')=0 then
1343 Result:=xtText
1344 else if CompareIdentifiers(Identifier,'SIZEOF')=0 then
1345 Result:=xtConstOrdInteger
1346 else if CompareIdentifiers(Identifier,'ORD')=0 then
1347 Result:=xtConstOrdInteger
1348 else if CompareIdentifiers(Identifier,'ASSIGNED')=0 then
1349 Result:=xtConstBoolean
1350 else if CompareIdentifiers(Identifier,'VARIANT')=0 then
1351 Result:=xtVariant
1352 else if CompareIdentifiers(Identifier,'CURRENCY')=0 then
1353 Result:=xtCurrency
1354 else if CompareIdentifiers(Identifier,'LONGINT')=0 then
1355 Result:=xtLongInt
1356 else if CompareIdentifiers(Identifier,'LONGWORD')=0 then
1357 Result:=xtLongWord
1358 else if CompareIdentifiers(Identifier,'WORD')=0 then
1359 Result:=xtWord
1360 else if CompareIdentifiers(Identifier,'LONGWORD')=0 then
1361 Result:=xtCardinal
1362 else if CompareIdentifiers(Identifier,'SMALLINT')=0 then
1363 Result:=xtSmallInt
1364 else if CompareIdentifiers(Identifier,'SHORTINT')=0 then
1365 Result:=xtShortInt
1366 else if CompareIdentifiers(Identifier,'BYTE')=0 then
1367 Result:=xtByte
1368 else if CompareIdentifiers(Identifier,'PCHAR')=0 then
1369 Result:=xtPChar
1370 else if IsWordBuiltInFunc.DoItCaseInsensitive(Identifier) then
1371 Result:=xtCompilerFunc
1372 else begin
1373 // compiler specific
1374 if (Compiler=pcPas2js) then begin
1375 if CompareIdentifiers(Identifier,'JSVALUE')=0 then
1376 exit(xtJSValue);
1377 if CompareIdentifiers(Identifier,'NATIVEINT')=0 then
1378 exit(xtNativeInt);
1379 if CompareIdentifiers(Identifier,'NATIVEUINT')=0 then
1380 exit(xtNativeUInt);
1381 end;
1382 if (Compiler=pcDelphi) then begin
1383 if CompareIdentifiers(Identifier,'NATIVEINT')=0 then
1384 exit(xtNativeInt);
1385 if CompareIdentifiers(Identifier,'NATIVEUINT')=0 then
1386 exit(xtNativeUInt);
1387 end;
1388 Result:=xtNone;
1389 end;
1390 end;
1391
CompareTypeAliasItemsnull1392 function CompareTypeAliasItems(Item1, Item2: Pointer): Integer;
1393 var
1394 xItem1: TTypeAliasItem absolute Item1;
1395 xItem2: TTypeAliasItem absolute Item2;
1396 begin
1397 Result := CompareIdentifiers(PChar(xItem1.AliasName), PChar(xItem2.AliasName));
1398 end;
1399
CompareTypeAliasItemStringnull1400 function CompareTypeAliasItemString(AliasName, Item: Pointer): Integer;
1401 var
1402 xAliasName: PChar absolute AliasName;
1403 xItem: TTypeAliasItem absolute Item;
1404 begin
1405 Result := CompareIdentifiers(xAliasName, PChar(xItem.AliasName));
1406 end;
1407
ExprTypeToStringnull1408 function ExprTypeToString(const ExprType: TExpressionType): string;
1409 begin
1410 Result:='Desc='+ExpressionTypeDescNames[ExprType.Desc]
1411 +' SubDesc='+ExpressionTypeDescNames[ExprType.SubDesc]
1412 +' '+FindContextToString(ExprType.Context);
1413 end;
1414
CreateExpressionTypenull1415 function CreateExpressionType(const Desc, SubDesc: TExpressionTypeDesc;
1416 const Context: TFindContext): TExpressionType;
1417 begin
1418 Result.Desc:=Desc;
1419 Result.SubDesc:=SubDesc;
1420 Result.Context:=Context;
1421 end;
1422
1423 { TFindContext }
1424
FindContextToStringnull1425 function FindContextToString(const FindContext: TFindContext;
1426 RelativeFilename: boolean): string;
1427 var
1428 IdentNode: TCodeTreeNode;
1429 begin
1430 Result:='';
1431 if FindContext.Node<>nil then begin
1432 Result:=Result+'Node="'+FindContext.Node.DescAsString+'"';
1433 IdentNode:=FindContext.Node;
1434 while IdentNode<>nil do begin
1435 if IdentNode.Desc in AllSimpleIdentifierDefinitions
1436 +[ctnIdentifier,ctnEnumIdentifier,ctnLabel]
1437 then begin
1438 Result:=Result+' Ident="'+
1439 FindContext.Tool.ExtractIdentifier(IdentNode.StartPos)+'"';
1440 break;
1441 end else if IdentNode.Desc=ctnGenericType then begin
1442 if IdentNode.FirstChild<>nil then
1443 Result:=Result+' Generic="'+
1444 FindContext.Tool.ExtractIdentifier(IdentNode.FirstChild.StartPos)+'"'
1445 else
1446 Result:=Result+' Generic=?';
1447 end else if IdentNode.Desc in [ctnProperty,ctnGlobalProperty] then begin
1448 Result:=Result+' PropName="'+
1449 FindContext.Tool.ExtractPropName(IdentNode,false)+'"';
1450 break;
1451 end else if IdentNode.Desc=ctnProcedure then begin
1452 Result:=Result+' Proc="'+FindContext.Tool.ExtractProcName(IdentNode,[])+'"';
1453 break;
1454 end;
1455 IdentNode:=IdentNode.Parent;
1456 end;
1457 if RelativeFilename then
1458 Result:=Result+' at "'+FindContext.Tool.CleanPosToStr(FindContext.Node.StartPos,true)+'"'
1459 else
1460 Result:=Result+' at "'+FindContext.Tool.CleanPosToRelativeStr(FindContext.Node.StartPos,'')+'"'
1461 end else
1462 Result:='nil';
1463 end;
1464
FindContextToStringnull1465 function FindContextToString(const FindContext: PFindContext;
1466 RelativeFilename: boolean): string;
1467 begin
1468 if FindContext=nil then
1469 Result:='-'
1470 else
1471 Result:=FindContextToString(FindContext^,RelativeFilename);
1472 end;
1473
CreateFindContextnull1474 function CreateFindContext(NewTool: TFindDeclarationTool;
1475 NewNode: TCodeTreeNode): TFindContext;
1476 begin
1477 Result.Node:=NewNode;
1478 Result.Tool:=NewTool;
1479 end;
1480
CreateFindContextnull1481 function CreateFindContext(Params: TFindDeclarationParams): TFindContext;
1482 begin
1483 Result.Node:=Params.NewNode;
1484 Result.Tool:=TFindDeclarationTool(Params.NewCodeTool);
1485 end;
1486
CreateFindContextnull1487 function CreateFindContext(BaseTypeCache: TBaseTypeCache): TFindContext;
1488 begin
1489 Result.Node:=BaseTypeCache.BaseNode;
1490 Result.Tool:=TFindDeclarationTool(BaseTypeCache.BaseTool);
1491 end;
1492
FindContextAreEqualnull1493 function FindContextAreEqual(const Context1, Context2: TFindContext): boolean;
1494 begin
1495 Result:=(Context1.Tool=Context2.Tool) and (Context1.Node=Context2.Node);
1496 end;
1497
CompareFindContextsnull1498 function CompareFindContexts(const Context1, Context2: PFindContext): integer;
1499 begin
1500 if Pointer(Context1^.Tool)>Pointer(Context2^.Tool) then
1501 Result:=1
1502 else if Pointer(Context1^.Tool)<Pointer(Context2^.Tool) then
1503 Result:=-1
1504 else if Pointer(Context1^.Node)>Pointer(Context2^.Node) then
1505 Result:=1
1506 else if Pointer(Context1^.Node)<Pointer(Context2^.Node) then
1507 Result:=-1
1508 else
1509 Result:=0;
1510 end;
1511
1512 procedure AddFindContext(var ListOfPFindContext: TFPList;
1513 const NewContext: TFindContext);
1514 var
1515 AddContext: PFindContext;
1516 begin
1517 if ListOfPFindContext=nil then ListOfPFindContext:=TFPList.Create;
1518 New(AddContext);
1519 AddContext^:=NewContext;
1520 ListOfPFindContext.Add(AddContext);
1521 end;
1522
IndexOfFindContextnull1523 function IndexOfFindContext(var ListOfPFindContext: TFPList;
1524 const AContext: PFindContext): integer;
1525 begin
1526 if ListOfPFindContext=nil then
1527 Result:=-1
1528 else begin
1529 Result:=ListOfPFindContext.Count-1;
1530 while (Result>=0)
1531 and (CompareFindContexts(AContext,
1532 PFindContext(ListOfPFindContext[Result]))<>0)
1533 do
1534 dec(Result);
1535 end;
1536 end;
1537
1538 procedure FreeListOfPFindContext(var ListOfPFindContext: TFPList);
1539 var
1540 CurContext: PFindContext;
1541 i: Integer;
1542 begin
1543 if ListOfPFindContext=nil then exit;
1544 for i:=0 to ListOfPFindContext.Count-1 do begin
1545 CurContext:=PFindContext(ListOfPFindContext[i]);
1546 Dispose(CurContext);
1547 end;
1548 ListOfPFindContext.Free;
1549 ListOfPFindContext:=nil;
1550 end;
1551
1552 { TGenericParamValueMapping }
1553
1554 constructor TGenericParamValueMapping.Create(pPrevBrother: TGenericParamValueMapping; pParam, pValue: TCodeTreeNode);
1555 begin
1556 if pPrevBrother <> nil then
1557 pPrevBrother.NextBrother := Self;
1558 GenericParamNode := pParam;
1559 SpecializeValueNode := pValue;
1560 end;
1561
1562 destructor TGenericParamValueMapping.Destroy;
1563 begin
1564 if NextBrother <> nil then
1565 NextBrother.Free;
1566 inherited Destroy;
1567 end;
1568
1569 { TFindIdentifierInUsesSection_FindMissingFPCUnit }
1570
1571 constructor TFindIdentifierInUsesSection_FindMissingFPCUnit.Create;
1572 begin
1573 inherited;
1574 FResults := TStringList.Create;
1575 FResults.CaseSensitive := True;
1576 FResults.Duplicates := dupIgnore;
1577 FResults.Sorted := True;
1578 end;
1579
1580 destructor TFindIdentifierInUsesSection_FindMissingFPCUnit.Destroy;
1581 begin
1582 FResults.Free;
1583
1584 inherited Destroy;
1585 end;
1586
TFindIdentifierInUsesSection_FindMissingFPCUnit.Findnull1587 function TFindIdentifierInUsesSection_FindMissingFPCUnit.Find(
1588 const AUnitName: string; const ADirectoryCache: TCTDirectoryCache): Boolean;
1589 var
1590 IRes: Integer;
1591 begin
1592 IRes := FResults.IndexOf(AUnitName);
1593 if IRes>=0 then
1594 Exit(Boolean(PtrInt(FResults.Objects[IRes])));
1595 FUnitName := AUnitName;
1596 ADirectoryCache.IterateFPCUnitsInSet(@Iterate);
1597 Result := FFound;
1598 FResults.AddObject(AUnitName, TObject(PtrInt(Result)));
1599 end;
1600
TFindIdentifierInUsesSection_FindMissingFPCUnit.IsInResultsnull1601 function TFindIdentifierInUsesSection_FindMissingFPCUnit.IsInResults(
1602 const AUnitName: string): Boolean;
1603 begin
1604 Result := FResults.IndexOf(AUnitName)>=0;
1605 end;
1606
1607 procedure TFindIdentifierInUsesSection_FindMissingFPCUnit.Iterate(
1608 const AFilename: string);
1609 begin
1610 FFound := FFound or SameFileName(FUnitName, ExtractFileNameOnly(AFilename));
1611 end;
1612
1613 { TTypeAliasOrderList }
1614
1615 constructor TTypeAliasOrderList.Create(const AliasNames: array of string);
1616 begin
1617 inherited Create;
1618
1619 FTree := TAVLTree.Create(@CompareTypeAliasItems);
1620 Add(AliasNames);
1621 end;
1622
1623 procedure TTypeAliasOrderList.Add(const AliasNames: array of string);
1624 var
1625 AliasName: string;
1626 begin
1627 for AliasName in AliasNames do
1628 Add(AliasName);
1629 end;
1630
1631 procedure TTypeAliasOrderList.Add(const AliasName: string);
1632 var
1633 NewItem: TTypeAliasItem;
1634 begin
1635 if IndexOf(AliasName) > -1 then Exit;
1636
1637 NewItem := TTypeAliasItem.Create;
1638 NewItem.AliasName := AliasName;
1639 NewItem.Position := FTree.Count;
1640 FTree.Add(NewItem);
1641 end;
1642
TTypeAliasOrderList.Comparenull1643 function TTypeAliasOrderList.Compare(const AliasName1, AliasName2: string
1644 ): Integer;
1645 var
1646 xAliasIndex1, xAliasIndex2: Integer;
1647 begin
1648 xAliasIndex1 := IndexOf(AliasName1);
1649 xAliasIndex2 := IndexOf(AliasName2);
1650 if (xAliasIndex1=-1) and (xAliasIndex2=-1) then
1651 Exit(0)
1652 else if (xAliasIndex2=-1) then
1653 Exit(-1)
1654 else if (xAliasIndex1=-1) then
1655 Exit(1)
1656 else
1657 Result := xAliasIndex1-xAliasIndex2;
1658 end;
1659
TTypeAliasOrderList.Comparenull1660 function TTypeAliasOrderList.Compare(const Operand1,
1661 Operand2: TOperand; Tool: TFindDeclarationTool; CleanPos: Integer
1662 ): TOperand;
1663 var
1664 xCompRes: Integer;
1665 begin
1666 // first check if one of the operands is a constant -> if yes, automatically
1667 // return the other
1668 // (x := f + 1; should return always type of f)
1669 if (Operand1.Expr.Desc in xtAllConstTypes) and not (Operand2.Expr.Desc in xtAllConstTypes) then
1670 Exit(Operand2)
1671 else
1672 if (Operand2.Expr.Desc in xtAllConstTypes) and not (Operand1.Expr.Desc in xtAllConstTypes) then
1673 Exit(Operand1);
1674
1675 // then compare base types
1676 xCompRes := Compare(
1677 Tool.FindExprTypeAsString(Operand1.Expr, CleanPos, nil),
1678 Tool.FindExprTypeAsString(Operand2.Expr, CleanPos, nil));
1679 // if base types are same, compare aliases
1680 if xCompRes = 0 then
1681 xCompRes := Compare(
1682 Tool.FindExprTypeAsString(Operand1.Expr, CleanPos, @Operand1.AliasType),
1683 Tool.FindExprTypeAsString(Operand2.Expr, CleanPos, @Operand2.AliasType));
1684 if xCompRes > 0 then
1685 Result := Operand2
1686 else
1687 Result := Operand1;
1688 end;
1689
1690 procedure TTypeAliasOrderList.Delete(const Pos: Integer);
1691 var
1692 xAVItem, xDelItem: TAVLTreeNode;
1693 xItem: TTypeAliasItem;
1694 begin
1695 xDelItem := nil;
1696 for xAVItem in FTree do
1697 begin
1698 xItem := TTypeAliasItem(xAVItem.Data);
1699 if xItem.Position = Pos then
1700 xDelItem := xAVItem
1701 else if xItem.Position > Pos then
1702 Dec(xItem.Position);
1703 end;
1704
1705 if xDelItem<>nil then
1706 FTree.FreeAndDelete(xDelItem);
1707 end;
1708
1709 procedure TTypeAliasOrderList.Delete(const AliasName: string);
1710 var
1711 xIndex: Integer;
1712 begin
1713 xIndex := IndexOf(AliasName);
1714 if xIndex<0 then Exit;
1715 Delete(xIndex);
1716 end;
1717
1718 destructor TTypeAliasOrderList.Destroy;
1719 begin
1720 FTree.FreeAndClear;
1721 FTree.Free;
1722
1723 inherited Destroy;
1724 end;
1725
IndexOfnull1726 function TTypeAliasOrderList.IndexOf(const AliasName: string): Integer;
1727 var
1728 xAVNode: TAVLTreeNode;
1729 begin
1730 xAVNode := FTree.FindKey(PChar(AliasName), @CompareTypeAliasItemString);
1731 if xAVNode<>nil then
1732 Result := TTypeAliasItem(xAVNode.Data).Position
1733 else
1734 Result := -1;
1735 end;
1736
1737 procedure TTypeAliasOrderList.Insert(const AliasName: string; const Pos: Integer
1738 );
1739 var
1740 xAVItem: TAVLTreeNode;
1741 xItem, NewItem: TTypeAliasItem;
1742 begin
1743 for xAVItem in FTree do
1744 begin
1745 xItem := TTypeAliasItem(xAVItem.Data);
1746 if xItem.Position >= Pos then
1747 Inc(xItem.Position);
1748 end;
1749
1750 NewItem := TTypeAliasItem.Create;
1751 NewItem.AliasName := AliasName;
1752 NewItem.Position := Pos;
1753 FTree.Add(NewItem);
1754 end;
1755
1756 procedure TTypeAliasOrderList.InsertAfter(const AliasName, AfterAlias: string);
1757 var
1758 xIndex: Integer;
1759 begin
1760 if IndexOf(AliasName) = -1 then
1761 begin
1762 xIndex := IndexOf(AfterAlias);
1763 if xIndex >= 0 then
1764 Insert(AliasName, xIndex+1)
1765 else
1766 Add(AliasName);
1767 end;
1768 end;
1769
1770 procedure TTypeAliasOrderList.InsertBefore(const AliasName, BeforeAlias: string
1771 );
1772 var
1773 xIndex: Integer;
1774 begin
1775 if IndexOf(AliasName) = -1 then
1776 begin
1777 xIndex := IndexOf(BeforeAlias);
1778 if xIndex >= 0 then
1779 Insert(AliasName, xIndex)
1780 else
1781 Add(AliasName);
1782 end;
1783 end;
1784
1785 { TFDHelpersListItem }
1786
CalcMemSizenull1787 function TFDHelpersListItem.CalcMemSize: PtrUInt;
1788 begin
1789 Result := InstanceSize;
1790 end;
1791
1792 { TFDHelpersList }
1793
CompareHelpersListnull1794 function CompareHelpersList(Item1, Item2: Pointer): Integer;
1795 var
1796 I1: TFDHelpersListItem absolute Item1;
1797 I2: TFDHelpersListItem absolute Item2;
1798 begin
1799 Result := ord(I1.ForExprType.Desc)-ord(I2.ForExprType.Desc);
1800 if Result<>0 then exit;
1801 Result := ComparePointers(I1.ForExprType.Context.Node, I2.ForExprType.Context.Node);
1802 end;
1803
CompareHelpersListExprTypenull1804 function CompareHelpersListExprType(Item1, Item2: Pointer): Integer;
1805 var
1806 I1: PExpressionType absolute Item1;
1807 I2: TFDHelpersListItem absolute Item2;
1808 begin
1809 Result := ord(I1^.Desc)-ord(I2.ForExprType.Desc);
1810 if Result<>0 then exit;
1811 Result := ComparePointers(I1^.Context.Node, I2.ForExprType.Context.Node);
1812 end;
1813
1814 procedure TFDHelpersList.AddFromList(const ExtList: TFDHelpersList);
CopyNodenull1815 function CopyNode(ANode: TAVLTreeNode): TFDHelpersListItem;
1816 var
1817 FromNode: TFDHelpersListItem;
1818 begin
1819 FromNode := TFDHelpersListItem(ANode.Data);
1820 if Kind=fdhlkDelphiHelper then
1821 if FTree.FindKey(FromNode, @CompareHelpersList) <> nil then
1822 Exit(nil); //FPC & Delphi don't support duplicate class helpers!
1823 Result := TFDHelpersListItem.Create;
1824 Result.HelperContext := FromNode.HelperContext;
1825 Result.ForExprType := FromNode.ForExprType;
1826 AddChronologically(Result);
1827 end;
1828 var
1829 Node: TAVLTreeNode;
1830 begin
1831 for Node in ExtList.FTree do
1832 CopyNode(Node);
1833 end;
1834
CalcMemSizenull1835 function TFDHelpersList.CalcMemSize: PtrUInt;
1836 var
1837 Node: TAVLTreeNode;
1838 begin
1839 Result:=PtrUInt(InstanceSize)+PtrUInt(FTree.InstanceSize);
1840 for Node in FTree do
1841 Inc(Result, TFDHelpersListItem(Node.Data).CalcMemSize);
1842 end;
1843
1844 procedure TFDHelpersList.WriteDebugReport;
1845 var
1846 Node: TAVLTreeNode;
1847 Item: TFDHelpersListItem;
1848 begin
1849 debugln(['TFDHelpersList.WriteDebugReport ',dbgs(Kind),' Count=',FTree.Count]);
1850 Node:=FTree.FindLowest;
1851 while Node<>nil do begin
1852 Item:=TFDHelpersListItem(Node.Data);
1853 debugln([' ForExprType=[',ExprTypeToString(Item.ForExprType),']',
1854 ' Helper=[',FindContextToString(Item.HelperContext),']']);
1855 Node:=FTree.FindSuccessor(Node);
1856 end;
1857 end;
1858
1859 procedure TFDHelpersList.AddChronologically(Item: TFDHelpersListItem);
1860 begin
1861 with Item.ForExprType.Context do begin
1862 // Note: ObjCCategory allows multiple helpers for a class (here: ForExprType)
1863 // => there can be multiple items with the same key in the tree which
1864 // must be chronologically sorted
1865 // -> append the new item rightmost by slightly increasing the key
1866 Node:=TCodeTreeNode(Pointer(Node)-SizeOf(Pointer));
1867 FTree.Add(Item);
1868 Node:=TCodeTreeNode(Pointer(Node)+SizeOf(Pointer));
1869 end;
1870 end;
1871
AddFromHelperNodenull1872 function TFDHelpersList.AddFromHelperNode(HelperNode: TCodeTreeNode;
1873 Tool: TFindDeclarationTool; Replace: Boolean): TFDHelpersListItem;
1874 var
1875 OldKey: TAVLTreeNode;
1876 ExprType: TExpressionType;
1877 begin
1878 //debugln(['TFDHelpersList.AddFromHelperNode Start ',Tool.CleanPosToStr(HelperNode.StartPos,true),' ',Tool.ExtractCode(HelperNode.StartPos,HelperNode.StartPos+20,[])]);
1879 ExprType:=Tool.FindExtendedExprOfHelper(HelperNode);
1880 //debugln(['TFDHelpersList.AddFromHelperNode ExprType=',ExprTypeToString(ExprType)]);
1881
1882 if ExprType.Desc in xtAllIdentTypes then
1883 begin
1884 if Kind=fdhlkDelphiHelper then begin
1885 // class/type/record helpers only allow one helper per class
1886 OldKey := FTree.FindKey(@ExprType, @CompareHelpersListExprType);
1887 if OldKey <> nil then
1888 begin
1889 Result:=TFDHelpersListItem(OldKey.Data);
1890 if Replace then begin
1891 // keep AVLNode, it may be in use by the iterator of SearchInHelpers
1892 Result.HelperContext.Node := HelperNode;
1893 Result.HelperContext.Tool := Tool;
1894 end;
1895 exit;
1896 end;
1897 end;
1898
1899 Result := TFDHelpersListItem.Create;
1900 Result.ForExprType := ExprType;
1901 Result.HelperContext.Node := HelperNode;
1902 Result.HelperContext.Tool := Tool;
1903 AddChronologically(Result);
1904 end else
1905 Result := nil;
1906 end;
1907
1908 procedure TFDHelpersList.Clear;
1909 begin
1910 FTree.FreeAndClear;
1911 end;
1912
Countnull1913 function TFDHelpersList.Count: Integer;
1914 begin
1915 Result := FTree.Count;
1916 end;
1917
1918 constructor TFDHelpersList.Create(aKind: TFDHelpersListKind);
1919 begin
1920 inherited Create;
1921 FKind:=aKind;
1922 FTree:=TAVLTree.Create(@CompareHelpersList);
1923 end;
1924
1925 procedure TFDHelpersList.DeleteHelperNode(HelperNode: TCodeTreeNode;
1926 Tool: TFindDeclarationTool);
1927 var
1928 OldKey: TAVLTreeNode;
1929 ExprType: TExpressionType;
1930 begin
1931 ExprType:=Tool.FindExtendedExprOfHelper(HelperNode);
1932
1933 if ExprType.Desc in xtAllIdentTypes then
1934 begin
1935 OldKey := FTree.FindKey(@ExprType, @CompareHelpersListExprType);
1936 if OldKey <> nil then
1937 FTree.FreeAndDelete(OldKey);
1938 end;
1939 end;
1940
1941 destructor TFDHelpersList.Destroy;
1942 begin
1943 Clear;
1944 FTree.Free;
1945 inherited Destroy;
1946 end;
1947
IterateFromClassNodenull1948 function TFDHelpersList.IterateFromClassNode(ClassNode: TCodeTreeNode;
1949 Tool: TFindDeclarationTool; out HelperContext: TFindContext; out
1950 Iterator: TAVLTreeNode): boolean;
1951 var
1952 ExprType: TExpressionType;
1953 begin
1954 ExprType.Desc:=xtContext;
1955 ExprType.Context.Node:=ClassNode;
1956 ExprType.Context.Tool:=Tool;
1957 Iterator := FTree.FindRightMostKey(@ExprType, @CompareHelpersListExprType);
1958 if Iterator=nil then exit(false);
1959 HelperContext:=TFDHelpersListItem(Iterator.Data).HelperContext;
1960 Result:=true;
1961 end;
1962
GetNextnull1963 function TFDHelpersList.GetNext(out HelperContext: TFindContext;
1964 var Iterator: TAVLTreeNode): boolean;
1965 var
1966 NextNode: TAVLTreeNode;
1967 begin
1968 NextNode:=FTree.FindPrecessor(Iterator);
1969 if (NextNode=nil) or (CompareHelpersList(NextNode.Data,Iterator.Data)<>0) then
1970 exit(false);
1971 // found an older compatible helper
1972 Iterator:=NextNode;
1973 HelperContext:=TFDHelpersListItem(Iterator.Data).HelperContext;
1974 Result:=true;
1975 end;
1976
FindFromExprTypenull1977 function TFDHelpersList.FindFromExprType(const ExprType: TExpressionType
1978 ): TFindContext;
1979 var
1980 Node: TAVLTreeNode;
1981 begin
1982 Node := FTree.FindRightMostKey(@ExprType, @CompareHelpersListExprType);
1983 if Node<>nil then
1984 Result := TFDHelpersListItem(Node.Data).HelperContext
1985 else
1986 Result := CleanFindContext;
1987 end;
1988
1989 constructor TFindUsedUnitReferences.Create(Tool: TFindDeclarationTool; AContextNode: TCodeTreeNode);
1990 begin
1991 inherited Create;
1992 Params:=TFindDeclarationParams.Create(Tool, AContextNode);
1993 end;
1994
1995 destructor TFindUsedUnitReferences.Destroy;
1996 begin
1997 FreeAndNil(Params);
1998 inherited Destroy;
1999 end;
2000
2001 { TFindDeclarationTool }
2002
FindDeclarationnull2003 function TFindDeclarationTool.FindDeclaration(const CursorPos: TCodeXYPosition;
2004 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
2005 var
2006 NewTool: TFindDeclarationTool;
2007 NewNode: TCodeTreeNode;
2008 begin
2009 Result:=FindDeclaration(CursorPos,DefaultFindSmartFlags,NewTool,NewNode,
2010 NewPos,NewTopLine);
2011 end;
2012
FindMainDeclarationnull2013 function TFindDeclarationTool.FindMainDeclaration(
2014 const CursorPos: TCodeXYPosition; out NewPos: TCodeXYPosition; out
2015 NewTopLine: integer): boolean;
2016 var
2017 NewTool: TFindDeclarationTool;
2018 NewNode: TCodeTreeNode;
2019 begin
2020 Result:=FindDeclaration(CursorPos,[fsfFindMainDeclaration],NewTool,NewNode,
2021 NewPos,NewTopLine);
2022 end;
2023
FindDeclarationOfIdentifiernull2024 function TFindDeclarationTool.FindDeclarationOfIdentifier(
2025 const CursorPos: TCodeXYPosition; Identifier: PChar;
2026 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
2027 var
2028 CleanCursorPos: integer;
2029 CursorNode: TCodeTreeNode;
2030 Params: TFindDeclarationParams;
2031 begin
2032 Result:=false;
2033 ActivateGlobalWriteLock;
2034 Params:=nil;
2035 try
2036 // build code tree
2037 {$IFDEF CTDEBUG}
2038 DebugLn('TFindDeclarationTool.FindDeclarationOfIdentifier A CursorPos=X',dbgs(CursorPos.X),',Y',dbgs(CursorPos.Y));
2039 {$ENDIF}
2040 BuildTreeAndGetCleanPos(trTillCursor,lsrEnd,CursorPos,CleanCursorPos,
2041 [btSetIgnoreErrorPos]);
2042 {$IFDEF CTDEBUG}
2043 DebugLn('TFindDeclarationTool.FindDeclarationOfIdentifier B CleanCursorPos=',dbgs(CleanCursorPos));
2044 {$ENDIF}
2045 // find CodeTreeNode at cursor
2046 CursorNode:=BuildSubTreeAndFindDeepestNodeAtPos(CleanCursorPos,true);
2047 // search
2048 Params:=TFindDeclarationParams.Create(Self, CursorNode);
2049 Params.SetIdentifier(Self,Identifier,nil);
2050 Params.Flags:=[fdfSearchInParentNodes,fdfExceptionOnNotFound,
2051 fdfExceptionOnPredefinedIdent,
2052 fdfTopLvlResolving,fdfSearchInAncestors,fdfSearchInHelpers,
2053 fdfIgnoreCurContextNode];
2054 FindIdentifierInContext(Params);
2055 // convert result to nice source position
2056 Params.PrettifyResult;
2057 Params.ConvertResultCleanPosToCaretPos;
2058 NewPos:=Params.NewPos;
2059 NewTopLine:=Params.NewTopLine;
2060 Result:=true;
2061 finally
2062 Params.Free;
2063 DeactivateGlobalWriteLock;
2064 end;
2065 end;
2066
FindDeclarationnull2067 function TFindDeclarationTool.FindDeclaration(const CursorPos: TCodeXYPosition;
2068 SearchSmartFlags: TFindSmartFlags; out NewExprType: TExpressionType; out
2069 NewPos: TCodeXYPosition; out NewTopLine, BlockTopLine,
2070 BlockBottomLine: integer): boolean;
2071 var
2072 CleanCursorPos: integer;
2073 CursorNode, ClassNode: TCodeTreeNode;
2074 DirectSearch, SkipChecks, SearchForward: boolean;
2075
2076 function CheckIfNodeIsForwardDefinedClass(ANode: TCodeTreeNode;
2077 ATool: TFindDeclarationTool): Boolean;
2078 var
2079 TypeNode: TCodeTreeNode;
2080 begin
2081 Result := False;
2082 if not (ANode.Desc in [ctnTypeDefinition,ctnGenericType]) then exit;
2083 TypeNode:=ATool.FindTypeNodeOfDefinition(ANode);
2084 if (TypeNode<>nil)
2085 and (TypeNode.Desc in AllClasses)
2086 and ((TypeNode.SubDesc and ctnsForwardDeclaration)>0)
2087 then
2088 Result := True;
2089 end;
2090
2091 procedure CheckIfCursorOnAForwardDefinedClass;
2092 begin
2093 if SkipChecks then exit;
2094 if CheckIfNodeIsForwardDefinedClass(CursorNode, Self) then
2095 begin
2096 DirectSearch:=true;
2097 SearchForward:=true;
2098 SkipChecks:=true;
2099 end;
2100 end;
2101
2102 procedure CheckIfCursorInClassNode;
2103 begin
2104 if SkipChecks then exit;
2105 ClassNode:=CursorNode;
2106 while (ClassNode<>nil)
2107 and (not (ClassNode.Desc in AllClasses))
2108 do
2109 ClassNode:=ClassNode.Parent;
2110 if ClassNode=nil then exit;
2111 // cursor is in class/object/class interface definition
2112 if (ClassNode.SubDesc and ctnsForwardDeclaration)>0 then exit;
2113 // parse class and build CodeTreeNodes for all properties/methods
2114 CursorNode:=FindDeepestNodeAtPos(ClassNode,CleanCursorPos,true);
2115 if CursorNode.GetNodeOfType(ctnClassInheritance)=nil then exit;
2116 // identifier is an ancestor/interface identifier
2117 CursorNode:=ClassNode.Parent;
2118 DirectSearch:=true;
2119 SkipChecks:=true;
2120 end;
2121
2122 procedure CheckIfCursorInProcNode;
2123 var IsMethod: boolean;
2124 begin
2125 if SkipChecks then exit;
2126 if CursorNode.Desc=ctnProcedureHead then
2127 CursorNode:=CursorNode.Parent;
2128 if CursorNode.Desc<>ctnProcedure then exit;
2129 BuildSubTreeForProcHead(CursorNode);
2130 CursorNode:=FindDeepestNodeAtPos(CursorNode,CleanCursorPos,true);
2131 // check if cursor on proc name
2132 if (CursorNode.Desc=ctnProcedureHead)
2133 and (CleanCursorPos>=CursorNode.StartPos) then begin
2134 MoveCursorToNodeStart(CursorNode);
2135 ReadNextAtom;
2136 IsMethod:=false;
2137 if AtomIsIdentifier then begin
2138 ReadNextAtom;
2139 if AtomIsChar('.') then begin
2140 ReadNextAtom;
2141 ReadNextAtom;
2142 IsMethod:=true;
2143 end;
2144 end;
2145 if (CurPos.StartPos>CleanCursorPos) and (not IsMethod) then begin
2146 // cursor on proc name
2147 // -> ignore proc name and search overloaded identifier
2148 DirectSearch:=true;
2149 SkipChecks:=true;
2150 end;
2151 end;
2152 if CursorNode.Desc=ctnProcedureHead then
2153 CursorNode:=CursorNode.Parent;
2154 end;
2155
2156 procedure CheckIfCursorInPropertyNode;
2157 begin
2158 if SkipChecks then exit;
2159 if not (CursorNode.Desc in [ctnProperty,ctnGlobalProperty]) then exit;
2160 MoveCursorToNodeStart(CursorNode);
2161 if (CursorNode.Desc=ctnProperty) then begin
2162 ReadNextAtom; // read 'property'
2163 if UpAtomIs('CLASS') then ReadNextAtom;
2164 end;
2165 ReadNextAtom; // read property name
2166 if CleanCursorPos<CurPos.EndPos then begin
2167 DirectSearch:=true;
2168 SkipChecks:=true;
2169 end;
2170 end;
2171
2172 function FindSourceName(ACode: TCodeBuffer): boolean;
2173 var
2174 NamePos: TAtomPosition;
2175 begin
2176 Result:=false;
2177 NewExprType :=CleanExpressionType;
2178 if Assigned(FOnGetCodeToolForBuffer) then
2179 NewExprType.Context.Tool:=FOnGetCodeToolForBuffer(Self,ACode,false);
2180 if NewExprType.Context.Tool=nil then exit;
2181 NewExprType.Context.Tool.BuildTree(lsrSourceName);
2182 if not NewExprType.Context.Tool.GetSourceNamePos(NamePos) then exit;
2183 NewExprType.Context.Node:=NewExprType.Context.Tool.Tree.Root;
2184 if not NewExprType.Context.Tool.JumpToCleanPos(NamePos.StartPos,NamePos.StartPos,
2185 NamePos.StartPos,NewPos,NewTopLine,BlockTopLine,BlockBottomLine,false)
2186 then exit;
2187 Result:=true;
2188 NewExprType.Desc:=xtContext;
2189 end;
2190
2191 {$IFDEF VerboseFindDeclarationFail}
2192 procedure WriteFailReport;
2193 var
2194 CodePos: integer;
2195 LinkIndex: Integer;
2196 Link: TSourceLink;
2197 i: Integer;
2198 SrcCodes: TAVLTree;
2199 SrcNode: TAVLTreeNode;
2200 begin
2201 debugln(['TFindDeclarationTool.FindDeclaration failed',
2202 ' CursorPos=X=',CursorPos.X,',Y=',CursorPos.Y,
2203 ',File=',CursorPos.Code.Filename,
2204 ',LineCount=',CursorPos.Code.LineCount]);
2205 if CursorPos.Y<=CursorPos.Code.LineCount then
2206 debugln([' Line="',dbgstr(CursorPos.Code.GetLine(CursorPos.Y-1),1,CursorPos.X-1),'|',dbgstr(CursorPos.Code.GetLine(CursorPos.Y-1),CursorPos.X,1000),'"']);
2207 if CleanCursorPos>0 then begin
2208 debugln([ ' CleanCursorPos=',CleanCursorPos,' CleanCode="',dbgstr(Src,CleanCursorPos-40,40),'|',dbgstr(Src,CleanCursorPos,30),'"']);
2209 end;
2210 CursorPos.Code.LineColToPosition(CursorPos.Y,CursorPos.X,CodePos);
2211 LinkIndex:=Scanner.LinkIndexAtCursorPos(CodePos,CursorPos.Code);
2212 dbgout([' CodePos=',CodePos,' LinkIndex=',LinkIndex]);
2213 if LinkIndex>=0 then begin
2214 Link:=Scanner.Links[LinkIndex];
2215 dbgout([',CleanedPos=',Link.CleanedPos,',Size=',Scanner.LinkSize(LinkIndex),',SrcPos=',Link.SrcPos,',Kind=',dbgs(Link.Kind),',CodeSame=',Link.Code=Pointer(CursorPos.Code)]);
2216 end else begin
2217 dbgout([' LinkCount=',Scanner.LinkCount]);
2218 i:=0;
2219 while (i<Scanner.LinkCount-1) do begin
2220 Link:=Scanner.Links[i];
2221 if Link.Code=Pointer(CursorPos.Code) then begin
2222 if LinkIndex<0 then
2223 dbgout([', First Link of Code: ID=',i,',CleanedPos=',Link.CleanedPos,',Size=',Scanner.LinkSize(i),',SrcPos=',Link.SrcPos,',Kind=',dbgs(Link.Kind)]);
2224 LinkIndex:=i;
2225 end;
2226 inc(i);
2227 end;
2228 if LinkIndex>=0 then begin
2229 Link:=Scanner.Links[LinkIndex];
2230 dbgout([', Last Link of Code: ID=',LinkIndex,',CleanedPos=',Link.CleanedPos,',Size=',Scanner.LinkSize(i),',SrcPos=',Link.SrcPos,',Kind=',dbgs(Link.Kind)]);
2231 end else begin
2232 SrcCodes:=Scanner.CreateTreeOfSourceCodes;
2233 try
2234 for SrcNode in SrcCodes do begin
2235 dbgout(',LinkFile="',TCodeBuffer(SrcNode.Data).Filename,'"');
2236 end;
2237 finally
2238 SrcCodes.Free;
2239 end;
2240 end;
2241 end;
2242 debugln;
2243 end;
2244 {$ENDIF}
2245
2246 var
2247 IdentStartPos: Integer;
2248
2249 function TrySkipClassForward(Params: TFindDeclarationParams): Boolean;
2250 var
2251 ForwardXY, NewSkipPos: TCodeXYPosition;
2252 NewSkipExprType: TExpressionType;
2253 NewSkipTopLine, NewSkipCleanPos, NewSkipBlockTopLine,
2254 NewSkipBlockBottomLine: integer;
2255 begin
2256 // if we skip forward class definitions and we found one -> proceed search!
2257 Result :=
2258 (fsfSkipClassForward in SearchSmartFlags)
2259 and CheckIfNodeIsForwardDefinedClass(Params.NewNode, Params.NewCodeTool)
2260 and Params.NewCodeTool.CleanPosToCaret(Params.NewNode.StartPos, ForwardXY)
2261 and Params.NewCodeTool.FindDeclaration(ForwardXY, SearchSmartFlags-[fsfSkipClassForward],
2262 NewSkipExprType, NewSkipPos, NewSkipTopLine, NewSkipBlockTopLine, NewSkipBlockBottomLine);
2263
2264 if Result
2265 and (NewSkipExprType.Desc=xtContext)
2266 and (NewSkipExprType.Context.Tool=Self)
2267 and (NewSkipExprType.Context.Tool.CaretToCleanPos(NewSkipPos, NewSkipCleanPos)=0)
2268 and (IdentStartPos = GetIdentStartPosition(Src,NewSkipCleanPos))
2269 then begin
2270 // the old startpos and the skipclass startpos are the same -> we want to
2271 // jump to the forward declaration because we jump from the actual one
2272 Result := False;
2273 end;
2274
2275 if Result then
2276 begin
2277 NewExprType := NewSkipExprType;
2278 NewPos := NewSkipPos;
2279 NewTopLine := NewSkipTopLine;
2280 BlockTopLine := NewSkipBlockTopLine;
2281 BlockBottomLine := NewSkipBlockBottomLine;
2282 end;
2283 end;
2284
2285 var
2286 CleanPosInFront: integer;
2287 CursorAtIdentifier: boolean;
2288 IdentifierStart: PChar;
2289 LineRange: TLineRange;
2290 Params: TFindDeclarationParams;
2291 begin
2292 Result:=false;
2293 NewExprType:=CleanExpressionType;
2294 NewPos.X:=-1;
2295 NewPos.Y:=-1;
2296 SkipChecks:=false;
2297 // check cursor in source
2298 if (CursorPos.Y<1) or (CursorPos.Y>CursorPos.Code.LineCount)
2299 or (CursorPos.X<1) then begin
2300 {$IFDEF VerboseFindDeclarationFail}
2301 debugln(['TFindDeclarationTool.FindDeclaration invalid CursorPos=X=',CursorPos.X,' Y=',CursorPos.Y,' File=',CursorPos.Code.Filename,' LineCount=',CursorPos.Code.LineCount]);
2302 {$ENDIF}
2303 exit;
2304 end;
2305 CursorPos.Code.GetLineRange(CursorPos.Y-1,LineRange);
2306 if LineRange.EndPos-LineRange.StartPos+1<CursorPos.X then begin
2307 // beyond end of line
2308 {$IFDEF VerboseFindDeclarationFail}
2309 debugln(['TFindDeclarationTool.FindDeclaration beyond end of line: CursorPos=X=',CursorPos.X,' Y=',CursorPos.Y,' File=',CursorPos.Code.Filename,' LineLen=',LineRange.EndPos-LineRange.StartPos]);
2310 {$ENDIF}
2311 exit;
2312 end;
2313
2314 CleanCursorPos:=0;
2315 ActivateGlobalWriteLock;
2316 try
2317 // build code tree
2318 {$IFDEF CTDEBUG}
2319 DebugLn('TFindDeclarationTool.FindDeclaration A CursorPos=X',dbgs(CursorPos.X),',Y',dbgs(CursorPos.Y),' ',CursorPos.Code.Filename);
2320 debugln(['TFindDeclarationTool.FindDeclaration B ',dbgtext(copy(CursorPos.Code.GetLine(CursorPos.Y),1,CursorPos.X-1)),'|',dbgtext(copy(CursorPos.Code.GetLine(CursorPos.Y),CursorPos.X,120))]);
2321 {$ENDIF}
2322 BuildTreeAndGetCleanPos(trTillCursor,lsrEnd,CursorPos,CleanCursorPos,
2323 [btSetIgnoreErrorPos,btCursorPosOutAllowed]);
2324 {$IFDEF CTDEBUG}
2325 debugLn('TFindDeclarationTool.FindDeclaration B CleanCursorPos=',dbgs(CleanCursorPos));
2326 debugln(['TFindDeclarationTool.FindDeclaration C ',dbgtext(copy(Src,CleanCursorPos-30,30)),'|',dbgtext(copy(Src,CleanCursorPos,30))]);
2327 {$ENDIF}
2328
2329 // find CodeTreeNode at cursor
2330 if (Tree.Root<>nil) and (Tree.Root.StartPos<=CleanCursorPos) then begin
2331 CursorNode:=BuildSubTreeAndFindDeepestNodeAtPos(CleanCursorPos,true);
2332 if (fsfFindMainDeclaration in SearchSmartFlags)
2333 and CleanPosIsDeclarationIdentifier(CleanCursorPos,CursorNode)
2334 then begin
2335 //DebugLn(['TFindDeclarationTool.FindDeclaration CleanPosIsDeclarationIdentifier']);
2336 NewExprType.Desc:=xtContext;
2337 NewExprType.Context.Tool:=Self;
2338 NewExprType.Context.Node:=CursorNode;
2339 CleanCursorPos:=GetIdentStartPosition(Src,CleanCursorPos);
2340 if CursorNode.Desc=ctnVarDefinition then begin
2341 // if this is a parameter, try to find the corresponding declaration
2342 NewExprType.Context.Node:=FindCorrespondingProcParamNode(NewExprType.Context.Node);
2343 if (NewExprType.Context.Node<>nil) and (NewExprType.Context.Node.StartPos<CursorNode.StartPos) then
2344 CleanCursorPos:=NewExprType.Context.Node.StartPos
2345 else
2346 NewExprType.Context.Node:=CursorNode;
2347 end;
2348 if (CursorNode.Desc=ctnProcedureHead)
2349 and (NodeIsMethodBody(CursorNode.Parent)) then begin
2350 // if this is a procedure body, try to find the corresponding declaration
2351 NewExprType.Context.Node:=FindCorrespondingProcNode(CursorNode.Parent);
2352 if (NewExprType.Context.Node<>nil) and (NewExprType.Context.Node.Desc=ctnProcedure) then
2353 NewExprType.Context.Node:=NewExprType.Context.Node.FirstChild;
2354 if (NewExprType.Context.Node<>nil) and (NewExprType.Context.Node.StartPos<CursorNode.StartPos) then begin
2355 CleanCursorPos:=NewExprType.Context.Node.StartPos;
2356 end
2357 else
2358 NewExprType.Context.Node:=CursorNode;
2359 end;
2360
2361 Result:=JumpToCleanPos(CleanCursorPos,CleanCursorPos,CleanCursorPos,
2362 NewPos,NewTopLine,BlockTopLine,BlockBottomLine,false);
2363 {$IFDEF VerboseFindDeclarationFail}
2364 if not Result then begin
2365 debugln(['TFindDeclarationTool.FindDeclaration cursor at declaration, but JumpToCleanPos failed']);
2366 end;
2367 {$ENDIF}
2368 exit;
2369 end;
2370 CleanPosInFront:=CursorNode.StartPos;
2371 end else begin
2372 CleanPosInFront:=1;
2373 CursorNode:=nil;
2374 end;
2375 if IsIncludeDirectiveAtPos(CleanCursorPos,CleanPosInFront,NewPos.Code)
2376 then begin
2377 // include directive
2378 //DebugLn(['TFindDeclarationTool.FindDeclaration IsIncludeDirectiveAtPos']);
2379 NewPos.X:=1;
2380 NewPos.Y:=1;
2381 NewTopLine:=1;
2382 BlockTopLine:=NewPos.Y;
2383 BlockBottomLine:=NewPos.Y;
2384 NewExprType.Desc:=xtContext;
2385 NewExprType.Context.Node:=nil;
2386 NewExprType.Context.Tool:=Self;
2387 Result:=(fsfIncludeDirective in SearchSmartFlags);
2388 {$IFDEF VerboseFindDeclarationFail}
2389 if not Result then begin
2390 debugln(['TFindDeclarationTool.FindDeclaration cursor at include directive and fsfIncludeDirective not set']);
2391 end;
2392 {$ENDIF}
2393 exit;
2394 end;
2395 if CursorNode=nil then begin
2396 // raise exception
2397 RaiseCursorOutsideCode(CursorPos);
2398 end;
2399 {$IFDEF CTDEBUG}
2400 DbgOut(['TFindDeclarationTool.FindDeclaration D CursorNode=',NodeDescriptionAsString(CursorNode.Desc),' HasChildren=',dbgs(CursorNode.FirstChild<>nil)]);
2401 if CursorNode.Parent<>nil then
2402 DbgOut(' Parent="',CursorNode.Parent.DescAsString,'"');
2403 Debugln;
2404 {$ENDIF}
2405 if (CursorNode.Desc = ctnUseUnitNamespace) then begin
2406 NewExprType.Desc:=xtContext;
2407 NewExprType.Context.Node:=CursorNode;
2408 NewExprType.Context.Tool:=Self;
2409 CleanPosToCaret(CursorNode.StartPos, NewPos);
2410 NewTopLine := NewPos.Y;
2411 BlockTopLine := NewTopLine;
2412 CleanPosToCaret(CursorNode.EndPos, NewPos);
2413 BlockBottomLine := NewPos.Y;
2414 Result := True;
2415 Exit;
2416 end else
2417 if (CursorNode.Desc in [ctnUsesSection,ctnUseUnitClearName]) then begin
2418 // in uses section
2419 //DebugLn(['TFindDeclarationTool.FindDeclaration IsUsesSection']);
2420 Result:=FindDeclarationInUsesSection(CursorNode,CleanCursorPos,
2421 NewPos,NewTopLine);
2422 BlockTopLine:=NewPos.Y;
2423 BlockBottomLine:=NewPos.Y;
2424 NewExprType:=CleanExpressionType;
2425 {$IFDEF VerboseFindDeclarationFail}
2426 if not Result then begin
2427 debugln(['TFindDeclarationTool.FindDeclaration cursor in uses and FindDeclarationInUsesSection failed']);
2428 end;
2429 {$ENDIF}
2430 if Result and (fsfSearchSourceName in SearchSmartFlags) then begin
2431 Result:=FindSourceName(NewPos.Code);
2432 {$IFDEF VerboseFindDeclarationFail}
2433 if not Result then begin
2434 debugln(['TFindDeclarationTool.FindDeclaration cursor in uses and FindSourceName failed']);
2435 end;
2436 {$ENDIF}
2437 end;
2438 exit;
2439 end;
2440 DirectSearch:=false;
2441 SearchForward:=false;
2442 CheckIfCursorOnAForwardDefinedClass;
2443 CheckIfCursorInClassNode;
2444 CheckIfCursorInProcNode;
2445 CheckIfCursorInPropertyNode;
2446 // set cursor on identifier
2447 MoveCursorToCleanPos(CleanCursorPos);
2448 GetIdentStartEndAtPosition(Src,CleanCursorPos,
2449 CurPos.StartPos,CurPos.EndPos);
2450 IdentStartPos:=CurPos.StartPos;
2451 CursorAtIdentifier:=CurPos.StartPos<CurPos.EndPos;
2452 if CursorAtIdentifier then
2453 IdentifierStart:=@Src[CurPos.StartPos]
2454 else
2455 IdentifierStart:=PChar(Src);
2456 if CursorAtIdentifier then begin
2457 // find declaration of identifier
2458 Params:=TFindDeclarationParams.Create(Self, CursorNode);
2459 try
2460 Params.SetIdentifier(Self,IdentifierStart,@CheckSrcIdentifier);
2461 Params.Flags:=[fdfSearchInParentNodes,fdfExceptionOnNotFound,
2462 fdfExceptionOnPredefinedIdent,
2463 fdfTopLvlResolving,fdfSearchInAncestors,fdfSearchInHelpers];
2464 if fsfSkipClassForward in SearchSmartFlags then
2465 Include(Params.Flags,fdfSkipClassForward);
2466 if not DirectSearch then begin
2467 Result:=FindDeclarationOfIdentAtParam(Params, NewExprType);
2468 {$IFDEF VerboseFindDeclarationFail}
2469 if not Result then begin
2470 debugln(['TFindDeclarationTool.FindDeclaration FindDeclarationOfIdentAtParam failed']);
2471 end;
2472 {$ENDIF}
2473 if Result and TrySkipClassForward(Params) then
2474 Exit(True);
2475 end else begin
2476 Include(Params.Flags,fdfIgnoreCurContextNode);
2477 if SearchForward then
2478 Include(Params.Flags,fdfSearchForward);
2479 //debugln(['TFindDeclarationTool.FindDeclaration Flags=',dbgs(Params.Flags),' FindIdentifierInContext ...']);
2480 Result:=FindIdentifierInContext(Params);
2481 if Result then
2482 begin
2483 if TrySkipClassForward(Params) then
2484 Exit(True);
2485
2486 NewExprType.Desc:=xtContext;
2487 NewExprType.Context.Node:=Params.NewNode;
2488 NewExprType.Context.Tool:=Params.NewCodeTool;
2489 end;
2490 {$IFDEF VerboseFindDeclarationFail}
2491 if not Result then begin
2492 debugln(['TFindDeclarationTool.FindDeclaration FindIdentifierInContext failed']);
2493 end;
2494 {$ENDIF}
2495 end;
2496 if Result then begin
2497 Params.PrettifyResult;
2498 Params.ConvertResultCleanPosToCaretPos;
2499 NewPos:=Params.NewPos;
2500 NewTopLine:=Params.NewTopLine;
2501 BlockTopLine:=NewPos.Y;
2502 BlockBottomLine:=NewPos.Y;
2503 if (NewExprType.Desc=xtContext) and
2504 ((NewPos.Code=nil) or (NewExprType.Context.Node=nil))
2505 then begin
2506 if Params.IdentifierTool.IsPCharInSrc(Params.Identifier) then
2507 Params.IdentifierTool.MoveCursorToCleanPos(Params.Identifier)
2508 else
2509 MoveCursorToCleanPos(CleanCursorPos);
2510 Params.IdentifierTool.RaiseExceptionFmt(20170421200024,ctsIdentifierNotFound,
2511 [GetIdentifier(Params.Identifier)]);
2512 end;
2513 end;
2514 finally
2515 Params.Free;
2516 end;
2517 end else begin
2518 // find declaration of non identifier, e.g. numeric label
2519 {$IFDEF VerboseFindDeclarationFail}
2520 if not Result then begin
2521 debugln(['TFindDeclarationTool.FindDeclaration cursor at non identifier']);
2522 end;
2523 {$ENDIF}
2524 end;
2525 finally
2526 ClearIgnoreErrorAfter;
2527 DeactivateGlobalWriteLock;
2528 {$IFDEF VerboseFindDeclarationFail}
2529 WriteFailReport;
2530 {$ENDIF}
2531 end;
2532 end;
2533
FindDeclarationnull2534 function TFindDeclarationTool.FindDeclaration(const CursorPos: TCodeXYPosition;
2535 SearchSmartFlags: TFindSmartFlags; out NewExprType: TExpressionType; out
2536 NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
2537 var
2538 BlockTopLine, BlockBottomLine: integer;
2539 begin
2540 Result := FindDeclaration(CursorPos, SearchSmartFlags, NewExprType, NewPos,
2541 NewTopLine, BlockTopLine, BlockBottomLine);
2542 end;
2543
FindDeclarationnull2544 function TFindDeclarationTool.FindDeclaration(const CursorPos: TCodeXYPosition;
2545 SearchSmartFlags: TFindSmartFlags; out NewTool: TFindDeclarationTool; out
2546 NewNode: TCodeTreeNode; out NewPos: TCodeXYPosition; out NewTopLine,
2547 BlockTopLine, BlockBottomLine: integer): boolean;
2548 var
2549 ExprType: TExpressionType;
2550 begin
2551 Result := FindDeclaration(CursorPos, SearchSmartFlags, ExprType, NewPos, NewTopLine, BlockTopLine, BlockBottomLine) and
2552 (NewPos.X >= 0) and (NewPos.Y >= 0);
2553 if Result then begin
2554 NewTool := ExprType.Context.Tool;
2555 NewNode := ExprType.Context.Node;
2556 end else begin
2557 NewTool := nil;
2558 NewNode := nil;
2559 end;
2560 end;
2561
FindDeclarationnull2562 function TFindDeclarationTool.FindDeclaration(const CursorPos: TCodeXYPosition;
2563 SearchSmartFlags: TFindSmartFlags; out NewTool: TFindDeclarationTool; out
2564 NewNode: TCodeTreeNode; out NewPos: TCodeXYPosition; out NewTopLine: integer
2565 ): boolean;
2566 var
2567 BlockTopLine, BlockBottomLine: integer;
2568 begin
2569 Result := FindDeclaration(CursorPos, SearchSmartFlags, NewTool, NewNode, NewPos,
2570 NewTopLine, BlockTopLine, BlockBottomLine);
2571 end;
2572
FindDeclarationInInterfacenull2573 function TFindDeclarationTool.FindDeclarationInInterface(
2574 const Identifier: string; out NewPos: TCodeXYPosition; out NewTopLine,
2575 BlockTopLine, BlockBottomLine: integer): boolean;
2576 var
2577 Node: TCodeTreeNode;
2578 begin
2579 Result:=false;
2580 if Identifier='' then exit;
2581 Node:=FindDeclarationNodeInInterface(Identifier,true);
2582 if Node<>nil then
2583 Result:=JumpToNode(Node,NewPos,NewTopLine,BlockTopLine,BlockBottomLine,false);
2584 end;
2585
FindDeclarationWithMainUsesSectionnull2586 function TFindDeclarationTool.FindDeclarationWithMainUsesSection(
2587 const Identifier: string; out NewPos: TCodeXYPosition; out NewTopLine: integer
2588 ): boolean;
2589 var
2590 UsesNode: TCodeTreeNode;
2591 Params: TFindDeclarationParams;
2592 begin
2593 Result:=false;
2594 if Identifier='' then exit;
2595 BuildTree(lsrMainUsesSectionEnd);
2596 UsesNode:=FindMainUsesNode;
2597 if UsesNode=nil then exit;
2598
2599 Params:=TFindDeclarationParams.Create(Self, FindLastNode);
2600 ActivateGlobalWriteLock;
2601 try
2602 Params.Flags:=[fdfExceptionOnNotFound];
2603 Params.SetIdentifier(Self,PChar(Pointer(Identifier)),nil);
2604 if FindIdentifierInUsesSection(UsesNode,Params,True) then begin
2605 if Params.NewNode=nil then exit;
2606 Result:=Params.NewCodeTool.JumpToNode(Params.NewNode,NewPos,
2607 NewTopLine,false);
2608 end;
2609 finally
2610 Params.Free;
2611 DeactivateGlobalWriteLock;
2612 end;
2613 end;
2614
FindDeclarationOfPropertyPathnull2615 function TFindDeclarationTool.FindDeclarationOfPropertyPath(
2616 const PropertyPath: string; out NewContext: TFindContext;
2617 IgnoreTypeLess: boolean): boolean;
2618 // example: PropertyPath='TForm1.Font.Color'
2619 var
2620 StartPos: Integer;
2621
2622 function GetNextIdentifier: string;
2623 var
2624 EndPos: LongInt;
2625 begin
2626 EndPos:=StartPos;
2627 while (EndPos<=length(PropertyPath)) and (IsIdentChar[PropertyPath[EndPos]])
2628 do inc(EndPos);
2629 if (EndPos<=length(PropertyPath)) and (PropertyPath[EndPos]<>'.') then
2630 Result:=''
2631 else begin
2632 Result:=copy(PropertyPath,StartPos,EndPos-StartPos);
2633 StartPos:=EndPos+1;
2634 end;
2635 end;
2636
2637 var
2638 Params: TFindDeclarationParams;
2639 Identifier: String;
2640 IsLastProperty: Boolean;
2641 Context: TFindContext;
2642 IsTypeLess: Boolean;
2643 Node: TCodeTreeNode;
2644 begin
2645 Result:=false;
2646 NewContext:=CleanFindContext;
2647 //DebugLn('TFindDeclarationTool.FindDeclarationOfPropertyPath ',MainFilename,' PropertyPath="',PropertyPath,'"');
2648 if PropertyPath='' then exit;
2649 ActivateGlobalWriteLock;
2650 Params:=TFindDeclarationParams.Create(Self, FindLastNode);
2651 try
2652 BuildTree(lsrInitializationStart);
2653
2654 //DebugLn(['TFindDeclarationTool.FindDeclarationOfPropertyPath ',Src]);
2655
2656 // first search the class/variable in the interface
2657 StartPos:=1;
2658 Identifier:=GetNextIdentifier;
2659 if Identifier='' then exit;
2660 Context.Tool:=Self;
2661 Context.Node:=FindDeclarationNodeInInterface(Identifier,true);
2662 if Context.Node=nil then begin
2663 DebugLn(['TFindDeclarationTool.FindDeclarationOfPropertyPath Identifier not found in interface ',Identifier]);
2664 exit;
2665 end;
2666 Context:=FindBaseTypeOfNode(Params,Context.Node);
2667 if Context.Node=nil then begin
2668 DebugLn(['TFindDeclarationTool.FindDeclarationOfPropertyPath context not found']);
2669 exit;
2670 end;
2671 // then search the properties
2672 repeat
2673 Identifier:=GetNextIdentifier;
2674 IsLastProperty:=StartPos>length(PropertyPath);
2675 //DebugLn('TFindDeclarationTool.FindDeclarationOfPropertyPath Context=',Context.Node.DescAsString,' Identifier=',Identifier);
2676 if Identifier='' then begin
2677 NewContext:=Context;
2678 exit(true);
2679 end;
2680 if Context.Node.Desc=ctnSetType then begin
2681 // set
2682 if not IsLastProperty then exit;
2683 Node:=Context.Node.FirstChild;
2684 if (Node=nil) or (Node.Desc<>ctnIdentifier) then exit;
2685
2686 // search enum type
2687 Params.Flags:=[fdfExceptionOnNotFound,fdfSearchInParentNodes,fdfFindChildren];
2688 Params.SetIdentifier(Self,@Context.Tool.Src[Node.StartPos],nil);
2689 Params.ContextNode:=Node;
2690 if not Context.Tool.FindIdentifierInContext(Params) then exit;
2691
2692 Context.Tool:=Params.NewCodeTool;
2693 Context.Node:=Params.NewNode;
2694 // search enum base type
2695 Context:=Context.Tool.FindBaseTypeOfNode(Params,Context.Node);
2696 //debugln(['TFindDeclarationTool.FindDeclarationOfPropertyPath enum base type ',FindContextToString(Context)]);
2697 if (Context.Node=nil) or (Context.Node.Desc<>ctnEnumerationType) then
2698 exit;
2699 // search enum
2700 Node:=Context.Node.FirstChild;
2701 while Node<>nil do begin
2702 if CompareIdentifiers(PChar(Pointer(Identifier)),@Context.Tool.Src[Node.StartPos])=0
2703 then begin
2704 //debugln(['TFindDeclarationTool.FindDeclarationOfPropertyPath identifier=',Identifier]);
2705 NewContext.Tool:=Context.Tool;
2706 NewContext.Node:=Node;
2707 //debugln(['TFindDeclarationTool.FindDeclarationOfPropertyPath FOUND ',FindContextToString(NewContext)]);
2708 exit(true);
2709 end;
2710 Node:=Node.NextBrother;
2711 end;
2712 exit;
2713 end;
2714
2715 if (not (Context.Node.Desc in AllClasses)) then begin
2716 debugln(['TFindDeclarationTool.FindDeclarationOfPropertyPath failed Context=',Context.Node.DescAsString]);
2717 exit;
2718 end;
2719 //DebugLn('TFindDeclarationTool.FindDeclarationOfPropertyPath Identifier="',identifier,'"');
2720 Params.Flags:=[fdfExceptionOnNotFound,fdfSearchInAncestors,fdfSearchInHelpers];
2721 Params.SetIdentifier(Self,PChar(Pointer(Identifier)),nil);
2722 Params.ContextNode:=Context.Node;
2723 if IsLastProperty then
2724 Params.Flags:=Params.Flags+[fdfFindVariable]
2725 else
2726 Params.Flags:=Params.Flags-[fdfFindVariable]+[fdfFunctionResult,fdfFindChildren];
2727 if not Context.Tool.FindIdentifierInContext(Params) then exit;
2728 Context.Tool:=Params.NewCodeTool;
2729 Context.Node:=Params.NewNode;
2730 if Context.Node=nil then exit;
2731 if IsLastProperty then begin
2732 if IgnoreTypeLess then begin
2733 repeat
2734 IsTypeLess:=false;
2735 if (Context.Node.Desc=ctnProperty)
2736 and Context.Tool.PropNodeIsTypeLess(Context.Node) then
2737 IsTypeLess:=true;
2738 if not IsTypeLess then break;
2739 //DebugLn(['TFindDeclarationTool.FindDeclarationOfPropertyPath has no type, searching next ...']);
2740 Params.SetIdentifier(Self,PChar(Pointer(Identifier)),nil);
2741 Params.ContextNode:=Context.Tool.FindClassOrInterfaceNode(Context.Node);
2742 if Params.ContextNode=nil then
2743 Params.ContextNode:=Context.Node;
2744 Params.Flags:=[fdfExceptionOnNotFound,fdfSearchInAncestors,fdfSearchInHelpers,
2745 fdfFindVariable,fdfIgnoreCurContextNode];
2746 //DebugLn(['TFindDeclarationTool.FindDeclarationOfPropertyPath ',Context.Tool.MainFilename,' ',Params.ContextNode.DescAsString,' ',Context.Tool.CleanPosToStr(Params.ContextNode.StartPos)]);
2747 if not Context.Tool.FindIdentifierInContext(Params) then exit;
2748 Context.Tool:=Params.NewCodeTool;
2749 Context.Node:=Params.NewNode;
2750 if Context.Node=nil then exit;
2751 until false;
2752 end;
2753 //DebugLn(['TFindDeclarationTool.FindDeclarationOfPropertyPath FOUND']);
2754 NewContext:=Context;
2755 Result:=true;
2756 exit;
2757 end else begin
2758 Context:=Context.Tool.FindBaseTypeOfNode(Params,Context.Node);
2759 if Context.Node=nil then exit;
2760 end;
2761 until false;
2762 finally
2763 Params.Free;
2764 DeactivateGlobalWriteLock;
2765 end;
2766 end;
2767
FindDeclarationOfPropertyPathnull2768 function TFindDeclarationTool.FindDeclarationOfPropertyPath(
2769 const PropertyPath: string;
2770 out NewPos: TCodeXYPosition; out NewTopLine: integer;
2771 IgnoreTypeLess: boolean): boolean;
2772 var
2773 Context: TFindContext;
2774 begin
2775 Result:=FindDeclarationOfPropertyPath(PropertyPath,Context,IgnoreTypeLess);
2776 if not Result then exit;
2777 Result:=Context.Tool.JumpToNode(Context.Node,NewPos,NewTopLine,false);
2778 end;
2779
FindDeclarationNodeInInterfacenull2780 function TFindDeclarationTool.FindDeclarationNodeInInterface(
2781 const Identifier: string; BuildTheTree: Boolean): TCodeTreeNode;
2782 var
2783 CacheEntry: PInterfaceIdentCacheEntry;
2784 begin
2785 Result:=nil;
2786 if Identifier='' then exit;
2787 if BuildTheTree and (not BuildInterfaceIdentifierCache(true)) then
2788 exit;
2789 CacheEntry:=FInterfaceIdentifierCache.FindIdentifier(PChar(Identifier));
2790 if CacheEntry=nil then exit;
2791 Result:=CacheEntry^.Node;
2792 end;
2793
FindDeclarationNodeInImplementationnull2794 function TFindDeclarationTool.FindDeclarationNodeInImplementation(
2795 Identifier: string; BuildTheTree: Boolean): TCodeTreeNode;
2796 begin
2797 Result:=nil;
2798 if Identifier='' then exit;
2799 if BuildTheTree then
2800 BuildTree(lsrInitializationStart);
2801 Result:=FindSubDeclaration(Identifier,FindImplementationNode);
2802 end;
2803
FindSubDeclarationnull2804 function TFindDeclarationTool.FindSubDeclaration(Identifier: string;
2805 ParentNode: TCodeTreeNode): TCodeTreeNode;
2806 var
2807 LastNode: TCodeTreeNode;
2808 begin
2809 Result:=nil;
2810 if ParentNode=nil then exit;
2811 if Identifier='' then exit;
2812 Identifier:=UpperCaseStr(Identifier);
2813 LastNode:=ParentNode.NextSkipChilds;
2814 Result:=ParentNode.Next;
2815 while Result<>LastNode do begin
2816 // ToDo: check enums
2817 if Result.Desc in AllIdentifierDefinitions then begin
2818 if CompareNodeIdentChars(Result,Identifier)=0 then
2819 exit;
2820 Result:=Result.NextSkipChilds;
2821 end else if Result.Desc=ctnProcedure then begin
2822 if CompareIdentifiers(PChar(ExtractProcName(Result,[])),PChar(Pointer(Identifier)))=0 then
2823 exit;
2824 Result:=Result.NextSkipChilds;
2825 end else
2826 Result:=Result.Next;
2827 end;
2828 Result:=nil;
2829 end;
2830
FindNameInUsesSectionnull2831 function TFindDeclarationTool.FindNameInUsesSection(UsesNode: TCodeTreeNode;
2832 const AUnitName: string): TCodeTreeNode;
2833 var
2834 CurUnitName: string;
2835 begin
2836 Result:=UsesNode.FirstChild;
2837 while (Result<>nil) do begin
2838 CurUnitName:=ExtractUsedUnitName(Result);
2839 if CompareDottedIdentifiers(PChar(CurUnitName),PChar(AUnitName))=0 then exit;
2840 Result:=Result.NextBrother;
2841 end;
2842 end;
2843
FindUnitInUsesSectionnull2844 function TFindDeclarationTool.FindUnitInUsesSection(UsesNode: TCodeTreeNode;
2845 const AnUnitName: string; out NamePos, InPos: TAtomPosition): boolean;
2846 var
2847 CurUnitName: String;
2848 StartPos: Integer;
2849 begin
2850 Result:=false;
2851 NamePos:=CleanAtomPosition;
2852 InPos:=CleanAtomPosition;
2853 if (UsesNode=nil) or (not IsDottedIdentifier(AnUnitName))
2854 or (UsesNode.Desc<>ctnUsesSection) then begin
2855 DebugLn(['TFindDeclarationTool.FindUnitInUsesSection invalid AnUnitName']);
2856 exit;
2857 end;
2858 MoveCursorToNodeStart(UsesNode);
2859 ReadNextAtom; // read 'uses'
2860 repeat
2861 ReadNextAtom; // read name
2862 if CurPos.Flag=cafSemicolon then break;
2863 if (CurPos.StartPos>SrcLen) then break;
2864 StartPos:=CurPos.StartPos;
2865 CurUnitName:=ExtractUsedUnitNameAtCursor;
2866 if CompareDottedIdentifiers(PChar(CurUnitName),PChar(AnUnitName))=0 then
2867 begin
2868 MoveCursorToCleanPos(StartPos);
2869 ReadNextAtom;
2870 ReadNextUsedUnit(NamePos,InPos);
2871 Result:=true;
2872 exit;
2873 end;
2874 if CurPos.Flag=cafSemicolon then break;
2875 if CurPos.Flag<>cafComma then break;
2876 until (CurPos.StartPos>SrcLen);
2877 end;
2878
FindUnitInAllUsesSectionsnull2879 function TFindDeclarationTool.FindUnitInAllUsesSections(
2880 const AnUnitName: string; out NamePos, InPos: TAtomPosition): boolean;
2881
2882 procedure RaiseInvalidUnitName;
2883 begin
2884 raise Exception.Create('invalid unit name '+AnUnitName);
2885 end;
2886
2887 function FindInSection(UsesNode: TCodeTreeNode): boolean;
2888 begin
2889 Result:=(UsesNode<>nil)
2890 and FindUnitInUsesSection(UsesNode,AnUnitName,NamePos,InPos);
2891 end;
2892
2893 begin
2894 Result:=false;
2895 NamePos.StartPos:=-1;
2896 InPos.StartPos:=-1;
2897 if not IsDottedIdentifier(AnUnitName) then
2898 RaiseInvalidUnitName;
2899 BuildTree(lsrImplementationUsesSectionEnd);
2900 if FindInSection(FindMainUsesNode) then exit;
2901 if FindInSection(FindImplementationUsesNode) then exit;
2902 end;
2903
GetUnitNameForUsesSectionnull2904 function TFindDeclarationTool.GetUnitNameForUsesSection(
2905 TargetTool: TFindDeclarationTool): string;
2906 // if unit is already used return ''
2907 // else return nice name
2908 var
2909 UsesNode: TCodeTreeNode;
2910 Alternative: String;
2911 begin
2912 Result:='';
2913 if (TargetTool=nil) or (TargetTool.MainFilename='') or (TargetTool=Self) then
2914 exit;
2915 Result:=ExtractFileNameOnly(TargetTool.MainFilename);
2916 if Result='' then exit;
2917
2918 // check if system unit
2919 if IsHiddenUsedUnit(PChar(Result)) then begin
2920 Result:='';
2921 exit;
2922 end;
2923
2924 // check if already there
2925 UsesNode:=FindMainUsesNode;
2926 if (UsesNode<>nil) and (FindNameInUsesSection(UsesNode,Result)<>nil)
2927 then begin
2928 Result:='';
2929 exit;
2930 end;
2931 UsesNode:=FindImplementationUsesNode;
2932 if (UsesNode<>nil) and (FindNameInUsesSection(UsesNode,Result)<>nil)
2933 then begin
2934 Result:='';
2935 exit;
2936 end;
2937
2938 // beautify
2939 if Result=lowercase(Result) then begin
2940 Alternative:=TargetTool.GetSourceName(false);
2941 if Alternative<>'' then
2942 Result:=Alternative;
2943 end;
2944 end;
2945
IsHiddenUsedUnitnull2946 function TFindDeclarationTool.IsHiddenUsedUnit(TheUnitName: PChar): boolean;
2947 var
2948 HiddenUnits: String;
2949 p: PChar;
2950 begin
2951 if TheUnitName=nil then exit(false);
2952 HiddenUnits:=Scanner.GetHiddenUsedUnits;
2953 if HiddenUnits<>'' then begin
2954 p:=PChar(HiddenUnits);
2955 while p^<>#0 do begin
2956 if CompareDottedIdentifiers(TheUnitName,p)=0 then
2957 exit(true);
2958 while not (p^ in [',',#0]) do inc(p);
2959 while p^=',' do inc(p);
2960 end;
2961 end;
2962 Result:=false;
2963 end;
2964
FindDeclarationInUsesSectionnull2965 function TFindDeclarationTool.FindDeclarationInUsesSection(
2966 UsesNode: TCodeTreeNode; CleanPos: integer;
2967 out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
2968 var AUnitName, UnitInFilename: string;
2969 UnitNamePos, UnitInFilePos: TAtomPosition;
2970 begin
2971 Result:=false;
2972 {$IFDEF ShowTriedContexts}
2973 DebugLn('TFindDeclarationTool.FindDeclarationInUsesSection A');
2974 {$ENDIF}
2975 {$IFDEF CheckNodeTool}CheckNodeTool(UsesNode);{$ENDIF}
2976 // reparse uses section, ignore errors after CleanPos
2977 MoveCursorToNodeStart(UsesNode);
2978 if (UsesNode.Desc=ctnUsesSection) then begin
2979 ReadNextAtom;
2980 if not UpAtomIs('USES') then
2981 RaiseUsesExpected(20170421200506);
2982 end else
2983 if (UsesNode.Desc = ctnUseUnitClearName) then
2984 MoveCursorToNodeStart(UsesNode.Parent);
2985
2986 repeat
2987 ReadNextAtom; // read name
2988 if CurPos.StartPos>CleanPos then break;
2989 if CurPos.Flag=cafSemicolon then break;
2990 ReadNextUsedUnit(UnitNamePos,UnitInFilePos);
2991 if CleanPos<=CurPos.StartPos then begin
2992 // cursor is on an used unit -> try to locate it
2993 MoveCursorToCleanPos(UnitNamePos.StartPos);
2994 ReadNextAtom;
2995 AUnitName:=ExtractUsedUnitNameAtCursor(@UnitInFilename);
2996 NewPos.Code:=FindUnitSource(AUnitName,UnitInFilename,true,UnitNamePos.StartPos);
2997 NewPos.X:=1;
2998 NewPos.Y:=1;
2999 NewTopLine:=1;
3000 Result:=true;
3001 exit;
3002 end;
3003 if CurPos.Flag=cafSemicolon then break;
3004 if CurPos.Flag<>cafComma then
3005 RaiseExceptionFmt(20170421200032,ctsStrExpectedButAtomFound,[';',GetAtom])
3006 until (CurPos.StartPos>SrcLen);
3007 {$IFDEF ShowTriedContexts}
3008 DebugLn('TFindDeclarationTool.FindDeclarationInUsesSection END cursor not on AUnitName');
3009 {$ENDIF}
3010 end;
3011
FindUnitFileInUsesSectionnull3012 function TFindDeclarationTool.FindUnitFileInUsesSection(
3013 UsesNode: TCodeTreeNode; const AFilename: string): TCodeTreeNode;
3014 var
3015 TargetLoUnitName: string;
3016 TargetLoShortFilename: string;
3017
3018 function CheckUseNode(Node: TCodeTreeNode): boolean;
3019 var
3020 Code: TCodeBuffer;
3021 UnitInFilename: string;
3022 AUnitName: string;
3023 begin
3024 Result:=false;
3025 MoveCursorToNodeStart(Node);
3026 ReadNextAtom;
3027 AUnitName:=ExtractUsedUnitNameAtCursor(@UnitInFilename);
3028 if AUnitName='' then exit;
3029
3030 // quick check: compare unitname
3031 if UnitInFilename<>'' then begin
3032 if lowercase(ExtractFilename(UnitInFilename))<>TargetLoShortFilename then
3033 exit;
3034 end else if LowerCase(AUnitName)<>TargetLoUnitName then
3035 exit;
3036
3037 // search in search paths
3038 Code:=FindUnitSource(AUnitName,UnitInFilename,false,Node.StartPos);
3039 Result:=(Code<>nil) and (CompareFilenames(Code.Filename,AFilename)=0);
3040 end;
3041
3042 begin
3043 Result:=nil;
3044 if (UsesNode=nil) or (UsesNode.Desc<>ctnUsesSection) then exit;
3045 TargetLoUnitName:=LowerCase(ExtractFileNameOnly(AFilename));
3046 TargetLoShortFilename:=LowerCase(ExtractFileName(AFilename));
3047 if TargetLoShortFilename='' then exit;
3048 Result:=UsesNode.LastChild;
3049 while Result<>nil do begin
3050 if CheckUseNode(Result) then exit;
3051 Result:=Result.PriorBrother;
3052 end;
3053 end;
3054
FindUnitFileInAllUsesSectionsnull3055 function TFindDeclarationTool.FindUnitFileInAllUsesSections(
3056 const AFilename: string; CheckMain: boolean; CheckImplementation: boolean
3057 ): TCodeTreeNode;
3058 begin
3059 Result:=nil;
3060 //debugln(['TFindDeclarationTool.FindUnitFileInAllUsesSections Self=',ExtractFilename(MainFilename),' Search=',ExtractFilename(AFilename)]);
3061 if AFilename='' then exit;
3062 if CheckMain then begin
3063 Result:=FindUnitFileInUsesSection(FindMainUsesNode,AFilename);
3064 //debugln(['TFindDeclarationTool.FindUnitFileInAllUsesSections Self=',ExtractFilename(MainFilename),' Search=',ExtractFilename(AFilename),' used in main uses=',Result<>nil]);
3065 if Result<>nil then exit;
3066 end;
3067 if CheckImplementation then
3068 Result:=FindUnitFileInUsesSection(FindImplementationUsesNode,AFilename);
3069 end;
3070
FindUnitSourcenull3071 function TFindDeclarationTool.FindUnitSource(const AnUnitName,
3072 AnUnitInFilename: string; ExceptionOnNotFound: boolean; ErrorPos: integer
3073 ): TCodeBuffer;
3074 var
3075 CompiledFilename: string;
3076 AFilename: String;
3077 NewUnitName: String;
3078 NewInFilename: String;
3079 NewCompiledUnitname: String;
3080 ErrMsg: string;
3081 begin
3082 {$IF defined(ShowTriedFiles) or defined(ShowTriedUnits)}
3083 DebugLn('TFindDeclarationTool.FindUnitSource Self="',MainFilename,'" AnUnitName="',AnUnitName,'" AnUnitInFilename="',AnUnitInFilename,'"');
3084 {$ENDIF}
3085 Result:=nil;
3086 if (AnUnitName='') or (Scanner=nil) then
3087 RaiseException(20171214184503,'TFindDeclarationTool.FindUnitSource Invalid Data');
3088 if (Scanner.MainCode=nil) then
3089 RaiseException(20171214184512,'TFindDeclarationTool.FindUnitSource Invalid Data');
3090 if (not (TObject(Scanner.MainCode) is TCodeBuffer)) then
3091 RaiseException(20171214184519,'TFindDeclarationTool.FindUnitSource Invalid Data');
3092 if (Scanner.OnLoadSource=nil) then
3093 RaiseException(20171214184527,'TFindDeclarationTool.FindUnitSource Invalid Data');
3094
3095 NewUnitName:=AnUnitName;
3096 NewInFilename:=AnUnitInFilename;
3097
3098 AFilename:=DirectoryCache.FindUnitSourceInCompletePath(
3099 NewUnitName,NewInFilename,false,false,AddedNameSpace);
3100 Result:=TCodeBuffer(Scanner.OnLoadSource(Self,AFilename,true));
3101
3102 if (Result=nil) and Assigned(OnFindUsedUnit) then begin
3103 // no unit found
3104 Result:=OnFindUsedUnit(Self,AnUnitName,AnUnitInFilename);
3105 end;
3106
3107 if Result=nil then begin
3108 // search .ppu
3109 NewCompiledUnitname:=AnUnitName+'.ppu';
3110 CompiledFilename:=DirectoryCache.FindCompiledUnitInCompletePath(
3111 NewCompiledUnitname,false);
3112 //debugln(['TFindDeclarationTool.FindUnitSource UnitName=',NewUnitName,' ',NewCompiledUnitname,' CompiledFilename=',CompiledFilename]);
3113 end else begin
3114 CompiledFilename:='';
3115 end;
3116
3117 if (Result=nil) and ExceptionOnNotFound then begin
3118 ErrMsg:='';
3119 if ErrorPos>0 then
3120 MoveCursorToCleanPos(ErrorPos)
3121 else if ErrorPos=0 then begin
3122 CurPos.StartPos:=-1;
3123 end else begin
3124 CurPos.StartPos:=-1;
3125 ErrMsg:=Format(ctsNeededByMode, [CompilerModeNames[Scanner.CompilerMode]]);
3126 end;
3127 if CompiledFilename<>'' then begin
3128 // there is a compiled unit, only the source was not found
3129 RaiseExceptionInstance(
3130 ECodeToolUnitNotFound.Create(Self,20170421200052,
3131 Format(ctsSourceNotFoundUnit+ErrMsg, [CompiledFilename]),
3132 AnUnitName));
3133 end else begin
3134 // nothing found
3135 RaiseExceptionInstance(
3136 ECodeToolUnitNotFound.Create(Self,20170421200056,
3137 Format(ctsUnitNotFound+ErrMsg,[AnUnitName]),
3138 AnUnitInFilename));
3139 end;
3140 end;
3141 end;
3142
FindUnitCaseInsensitivenull3143 function TFindDeclarationTool.FindUnitCaseInsensitive(var AnUnitName,
3144 AnUnitInFilename: string): string;
3145 begin
3146 Result:=DirectoryCache.FindUnitSourceInCompletePath(
3147 AnUnitName,AnUnitInFilename,true,false,AddedNameSpace);
3148 end;
3149
3150 procedure TFindDeclarationTool.GatherUnitAndSrcPath(var UnitPath,
3151 CompleteSrcPath: string);
3152 begin
3153 UnitPath:='';
3154 CompleteSrcPath:='';
3155 UnitPath:=DirectoryCache.Strings[ctdcsUnitPath];
3156 CompleteSrcPath:=DirectoryCache.Strings[ctdcsCompleteSrcPath];
3157 //DebugLn('TFindDeclarationTool.GatherUnitAndSrcPath UnitPath="',UnitPath,'" CompleteSrcPath="',CompleteSrcPath,'"');
3158 end;
3159
SearchUnitInUnitSetnull3160 function TFindDeclarationTool.SearchUnitInUnitSet(const TheUnitName: string): string;
3161 begin
3162 Result:=DirectoryCache.FindUnitInUnitSet(TheUnitName);
3163 end;
3164
GetNameSpacesnull3165 function TFindDeclarationTool.GetNameSpaces: string;
3166 begin
3167 Result:=DirectoryCache.Strings[ctdcsNamespaces];
3168 if AddedNameSpace<>'' then begin
3169 if Result<>'' then Result:=';'+Result;
3170 Result:=AddedNameSpace+Result;
3171 end;
3172 end;
3173
FindSmartHintnull3174 function TFindDeclarationTool.FindSmartHint(const CursorPos: TCodeXYPosition;
3175 Flags: TFindSmartFlags): string;
3176 var
3177 NewTool: TFindDeclarationTool;
3178 NewNode: TCodeTreeNode;
3179 NewPos: TCodeXYPosition;
3180 NewTopLine: integer;
3181 begin
3182 Result:='';
3183 if not FindDeclaration(CursorPos,Flags,NewTool,NewNode,NewPos,NewTopLine) then
3184 begin
3185 // identifier not found
3186 exit;
3187 end;
3188 Result:=NewTool.GetSmartHint(NewNode,NewPos,true);
3189 end;
3190
GetSmartHintnull3191 function TFindDeclarationTool.GetSmartHint(Node: TCodeTreeNode;
3192 XYPos: TCodeXYPosition; WithPosition: boolean; WithDefinition: boolean
3193 ): string;
3194
3195 function ReadIdentifierWithDots: String;
3196 begin
3197 Result := '';
3198 repeat
3199 ReadNextAtom;
3200 Result := Result + GetAtom;
3201 ReadNextAtom;
3202 if CurPos.Flag = cafPoint then
3203 Result := Result + '.'
3204 else
3205 break;
3206 until false;
3207 end;
3208
3209 function MoveToLastIdentifierThroughDots(ExtTool: TFindDeclarationTool): Boolean;
3210 var
3211 LastPos: TAtomPosition;
3212 begin
3213 LastPos := ExtTool.CurPos;
3214 ExtTool.ReadNextAtom;
3215 if ExtTool.CurPos.Flag = cafWord then
3216 ExtTool.ReadNextAtom;
3217 while ExtTool.CurPos.Flag = cafPoint do
3218 begin
3219 ExtTool.ReadNextAtom;
3220 LastPos := ExtTool.CurPos;
3221 ExtTool.ReadNextAtom;
3222 end;
3223 ExtTool.CurPos := LastPos;
3224 Result := True;
3225 end;
3226
3227 function ProceedWithSmartHint(ExtTool: TFindDeclarationTool): string;
3228 var
3229 CTExprType: TExpressionType;
3230 CTXYPos: TCodeXYPosition;
3231 CTTopLine: integer;
3232 CTCursorPos: TCodeXYPosition;
3233 begin
3234 MoveToLastIdentifierThroughDots(ExtTool);
3235 if ExtTool.CleanPosToCaret(ExtTool.CurPos.StartPos,CTCursorPos)
3236 and ExtTool.FindDeclaration(CTCursorPos,
3237 DefaultFindSmartHintFlags+[fsfSearchSourceName],CTExprType,CTXYPos,CTTopLine)
3238 and not((CTExprType.Desc=xtContext) and (CTExprType.Context.Node=nil) and (CTExprType.Context.Tool=nil))
3239 and not((CTExprType.Context.Tool=Self) and (CTXYPos.X=XYPos.X) and (CTXYPos.Y=XYPos.Y)) // prevent endless loop
3240 then
3241 Result := CTExprType.Context.Tool.GetSmartHint(CTExprType.Context.Node, CTXYPos, False, False)
3242 else
3243 Result := '';
3244 end;
3245 var
3246 IdentNode, TypeNode, ANode: TCodeTreeNode;
3247 ClassStr, NodeStr, SetStr: String;
3248 Params: TFindDeclarationParams;
3249 Tool: TFindDeclarationTool;
3250 HelperForNode: TCodeTreeNode;
3251 SubNode: TCodeTreeNode;
3252 begin
3253 Result:='';
3254
3255 { Examples:
3256 var i: integer
3257 /home/.../codetools/finddeclarationtools.pas(1224,7)
3258 }
3259 // identifier category and identifier
3260 if Node<>nil then begin
3261 // class visibility
3262 if Node.Parent<>nil then begin
3263 ANode:=Node.Parent;
3264 while ANode<>nil do begin
3265 case ANode.Desc of
3266 ctnClassPrivate:
3267 Result+='private ';
3268 ctnClassProtected:
3269 Result+='protected ';
3270 ctnClassPublic:
3271 Result+='public ';
3272 ctnClassPublished:
3273 Result+='published ';
3274 ctnClassClassVar:
3275 Result+='class ';
3276 else
3277 break;
3278 end;
3279 ANode:=ANode.Parent;
3280 end;
3281 end;
3282
3283 if Node.Desc = ctnGenericName then
3284 Node := Node.Parent;
3285 case Node.Desc of
3286 ctnIdentifier:
3287 if Assigned(Node.Parent) and (Node.Parent.Desc = ctnProcedureHead) then
3288 // function result
3289 Result := 'var Result: ' + ExtractNode(Node, []);
3290
3291 ctnVarDefinition, ctnTypeDefinition, ctnConstDefinition,
3292 ctnEnumIdentifier, ctnLabel, ctnGenericType:
3293 begin
3294 case Node.Desc of
3295 ctnVarDefinition: Result+='var ';
3296 ctnTypeDefinition: Result+='type ';
3297 ctnConstDefinition: Result+='const ';
3298 ctnEnumIdentifier: Result+='enum ';
3299 ctnLabel: Result+='label ';
3300 ctnGenericType: Result+='generic type ';
3301 end;
3302
3303 // add class name
3304 ClassStr := ExtractClassPath(Node.Parent);
3305 if ClassStr <> '' then Result += ClassStr + '.';
3306
3307 Result:=Result+ExtractDefinitionName(Node);
3308 TypeNode:=FindTypeNodeOfDefinition(Node);
3309 if not WithDefinition then Result := '';
3310 if TypeNode<>nil then begin
3311 case Node.Desc of
3312 ctnTypeDefinition, ctnGenericType:
3313 Result+=' = ';
3314 ctnConstDefinition:
3315 if TypeNode.Desc = ctnConstant then
3316 Result += ' = '
3317 else
3318 Result += ': ';
3319 ctnEnumIdentifier,ctnLabel: ;
3320 else
3321 Result += ': ';
3322 end;
3323 case TypeNode.Desc of
3324 ctnSetType:
3325 begin
3326 Result += ExtractNode(TypeNode, [phpCommentsToSpace]);
3327 MoveCursorToNodeStart(TypeNode);
3328 ReadNextAtom;
3329 if ReadNextUpAtomIs('OF') then
3330 begin
3331 if (Length(Result) > 0) and (Result[Length(Result)] = ';') then//delete last ";" from set
3332 Delete(Result, Length(Result), 1);
3333 ReadNextAtom;
3334 SetStr := ProceedWithSmartHint(Self);
3335 if (Length(SetStr) > 2) and (SetStr[2] = '=') then
3336 SetStr := Copy(SetStr, 4, High(Integer));
3337 if (SetStr <> '') then
3338 Result += ' = ['+SetStr+']';
3339 end;
3340 end;
3341 ctnIdentifier, ctnSpecialize, ctnSpecializeType,
3342 ctnPointerType, ctnRangeType, ctnFileType, ctnClassOfType:
3343 begin
3344 Result += ExtractNode(TypeNode, [phpCommentsToSpace]);
3345 MoveCursorToNodeStart(TypeNode);
3346 Result += ProceedWithSmartHint(Self);
3347 end;
3348 ctnClass, ctnClassInterface, ctnDispinterface,
3349 ctnClassHelper, ctnTypeHelper, ctnRecordHelper,
3350 ctnObject, ctnRangedArrayType, ctnOpenArrayType,
3351 ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass:
3352 begin
3353 MoveCursorToNodeStart(TypeNode);
3354 case TypeNode.Desc of
3355 ctnClass: Result:=Result+'class';
3356 ctnClassHelper: Result:=Result+'class helper';
3357 ctnRecordHelper: Result:=Result+'record helper';
3358 ctnTypeHelper: Result:=Result+'type helper';
3359 ctnObject: Result:=Result+'object';
3360 ctnObjCClass: Result:=Result+'objcclass';
3361 ctnObjCCategory: Result:=Result+'objccategory';
3362 ctnCPPClass: Result:=Result+'cppclass';
3363 ctnClassInterface: Result:=Result+'interface';
3364 ctnObjCProtocol: Result:=Result+'objcprotocol';
3365 ctnDispinterface: Result:=Result+'dispinterface';
3366 ctnRangedArrayType, ctnOpenArrayType: Result:=Result+'array';
3367 end;
3368 try
3369 BuildSubTree(TypeNode);
3370 except
3371 on ECodeToolError do ;
3372 end;
3373 SubNode:=FindInheritanceNode(TypeNode);
3374 if SubNode<>nil then
3375 Result:=Result+ExtractNode(SubNode,[]);
3376
3377 if TypeNode.Desc in [ctnClassHelper, ctnRecordHelper, ctnTypeHelper] then
3378 HelperForNode := FindHelperForNode(TypeNode)
3379 else
3380 HelperForNode := nil;
3381 if HelperForNode<>nil then
3382 Result:=Result+' '+ExtractNode(HelperForNode,[]);
3383 end;
3384 ctnRecordType:
3385 Result:=Result+'record';
3386 ctnTypeType:
3387 begin
3388 Result:=Result+'type';
3389 if TypeNode.FirstChild <> nil then
3390 Result:=Result+' '+ExtractNode(TypeNode.FirstChild,[]);
3391 end;
3392 ctnConstant:
3393 begin
3394 NodeStr:=ExtractNode(TypeNode,[phpCommentsToSpace]);
3395 Result+=copy(NodeStr,1,50);
3396 end;
3397 ctnEnumerationType:
3398 begin
3399 if Assigned(Node.FirstChild) then
3400 begin
3401 NodeStr:=ExtractCode(Node.FirstChild.StartPos,Node.FirstChild.EndPos,[phpCommentsToSpace]);
3402 if Length(NodeStr) > 50 then
3403 NodeStr:=Copy(NodeStr, 1, 50) + ' ...';
3404 Result += NodeStr;
3405 end else
3406 Result += 'enum';
3407 end;
3408 end;
3409 end else begin
3410 case Node.Desc of
3411 ctnConstDefinition:
3412 begin
3413 DebugLn('TFindDeclarationTool.GetSmartHint const without subnode "',ExtractNode(Node,[]),'"');
3414 NodeStr:=ExtractCode(Node.StartPos
3415 +GetIdentLen(@Src[Node.StartPos]),
3416 Node.EndPos,[phpCommentsToSpace]);
3417 Result+=copy(NodeStr,1,50);
3418 end;
3419 end;
3420 end;
3421 end;
3422
3423 ctnProcedure,ctnProcedureHead:
3424 begin
3425
3426 // ToDo: ppu, dcu files
3427
3428 Result+=ExtractProcHead(Node,
3429 [phpAddClassName,phpWithStart,phpWithVarModifiers,phpWithParameterNames,
3430 phpWithDefaultValues,phpWithResultType,phpWithOfObject,phpCommentsToSpace]);
3431 end;
3432
3433 ctnProperty,ctnGlobalProperty:
3434 begin
3435 IdentNode:=Node;
3436
3437 // ToDo: ppu, dcu files
3438
3439 Result+='property ';
3440 MoveCursorToNodeStart(IdentNode);
3441 ReadNextAtom;
3442 if Node.Desc = ctnProperty then begin
3443 // e.g. property Caption: string;
3444 // skip keyword
3445 ReadNextAtom;
3446 // add class name
3447 ClassStr := ExtractClassName(Node, False, True);
3448 if ClassStr <> '' then Result += ClassStr + '.';
3449 end else begin
3450 // global property starts with identifier
3451 end;
3452 // add name
3453 Result+=GetAtom;
3454
3455 Tool:=Self;
3456 while (Node.Desc=ctnProperty)
3457 and not Tool.MoveCursorToPropType(Node) do begin
3458 // property without type
3459 // -> search ancestor property
3460 if not Tool.MoveCursorToPropName(Node) then break;
3461 Params:=TFindDeclarationParams.Create(Tool, Node);
3462 try
3463 Params.SetIdentifier(Tool,@Tool.Src[Tool.CurPos.StartPos],nil);
3464 Params.Flags:=[fdfSearchInAncestors,fdfSearchInHelpers];
3465 if not Tool.FindIdentifierInAncestors(Node.Parent.Parent,Params) then break;
3466 Tool:=Params.NewCodeTool;
3467 Node:=Params.NewNode;
3468 finally
3469 Params.Free;
3470 end;
3471 end;
3472 if (Node<>nil) then begin
3473 if (Node.Desc in [ctnProperty,ctnGlobalProperty]) then begin
3474 Result += Tool.ExtractProperty(Node,
3475 [phpWithoutName,phpWithParameterNames,phpWithResultType]);
3476 end;
3477
3478 if Tool.MoveCursorToPropType(Node) then
3479 Result += ProceedWithSmartHint(Tool);
3480 end;
3481 end;
3482
3483 ctnProgram,ctnUnit,ctnPackage,ctnLibrary:
3484 begin
3485 IdentNode:=Node;
3486
3487 // ToDo: ppu, dcu files
3488
3489 MoveCursorToNodeStart(IdentNode);
3490 ReadNextAtom;
3491 if (IdentNode.Desc=ctnProgram) and not UpAtomIs('PROGRAM') then begin
3492 // program without source name
3493 Result:='program '+ExtractFileNameOnly(MainFilename)+' ';
3494 end else begin
3495 Result+=GetAtom+' '; // keyword
3496 Result := Result + ReadIdentifierWithDots + ' ';
3497 end;
3498 end;
3499
3500 ctnUseUnitNamespace:
3501 begin
3502 // hint for unit namespace in "uses" section
3503 Result += 'namespace ';
3504 MoveCursorToNodeStart(Node);
3505 ReadNextAtom;
3506 Result := Result + GetAtom;
3507 end;
3508
3509 ctnUseUnitClearName:
3510 begin
3511 // hint for unit in "uses" section
3512 Result += 'unit ';
3513 MoveCursorToNodeStart(Node.Parent);
3514 Result := Result + ReadIdentifierWithDots;
3515 end
3516
3517 else
3518 DebugLn('ToDo: TFindDeclarationTool.GetSmartHint ',Node.DescAsString);
3519 end;
3520 end;
3521 if WithPosition then begin
3522 // filename
3523 if Result<>'' then Result:=Result+LineEnding;
3524 if XYPos.Code=nil then
3525 CleanPosToCaret(Node.StartPos,XYPos);
3526 Result+=XYPos.Code.Filename;
3527 // file position
3528 if XYPos.Y>=1 then begin
3529 Result+='('+IntToStr(XYPos.Y);
3530 if XYPos.X>=1 then begin
3531 Result+=','+IntToStr(XYPos.X);
3532 end;
3533 Result+=')';
3534 end;
3535 end;
3536 end;
3537
BaseTypeOfNodeHasSubIdentsnull3538 function TFindDeclarationTool.BaseTypeOfNodeHasSubIdents(ANode: TCodeTreeNode
3539 ): boolean;
3540 var
3541 FindContext: TFindContext;
3542 Params: TFindDeclarationParams;
3543 begin
3544 {$IFDEF CheckNodeTool}CheckNodeTool(ANode);{$ENDIF}
3545 Result:=false;
3546 if (ANode=nil) then exit;
3547 ActivateGlobalWriteLock;
3548 Params:=TFindDeclarationParams.Create(Self, ANode);
3549 try
3550 Params.Flags:=Params.Flags+[fdfFunctionResult,fdfFindChildren];
3551 FindContext:=FindBaseTypeOfNode(Params,ANode);
3552 if (FindContext.Node<>nil)
3553 and ((FindContext.Node.Desc in ([ctnEnumerationType]+AllClasses)))
3554 and (FindContext.Node.FirstChild<>nil)
3555 then
3556 Result:=true;
3557 finally
3558 Params.Free;
3559 DeactivateGlobalWriteLock;
3560 end;
3561 end;
3562
IsIncludeDirectiveAtPosnull3563 function TFindDeclarationTool.IsIncludeDirectiveAtPos(CleanPos,
3564 CleanCodePosInFront: integer; out IncludeCode: TCodeBuffer): boolean;
3565 var LinkIndex, CommentStart, CommentEnd: integer;
3566 SrcLink: TSourceLink;
3567 begin
3568 Result:=false;
3569 IncludeCode:=nil;
3570 if (Scanner=nil) then exit;
3571 LinkIndex:=Scanner.LinkIndexAtCleanPos(CleanPos);
3572 if (LinkIndex<0) or (LinkIndex>=Scanner.LinkCount-1) then exit;
3573 SrcLink:=Scanner.Links[LinkIndex+1];
3574 if (SrcLink.Code=nil) or (SrcLink.Code=Scanner.Links[LinkIndex].Code) then
3575 exit;
3576 //DebugLn(['TFindDeclarationTool.IsIncludeDirectiveAtPos CleanPos=',CleanPos,' CleanCodePosInFront=',CleanCodePosInFront,' ',copy(Src,CleanCodePosInFront,10)]);
3577 if CleanPosIsInComment(CleanPos,CleanCodePosInFront,CommentStart,CommentEnd)
3578 and (CommentEnd=SrcLink.CleanedPos) then begin
3579 //DebugLn(['TFindDeclarationTool.IsIncludeDirectiveAtPos CommentStart=',CommentStart,' CommentEnd=',CommentEnd,' ',copy(Src,CommentStart,CommentEnd-CommentStart)]);
3580 IncludeCode:=TCodeBuffer(SrcLink.Code);
3581 Result:=true;
3582 exit;
3583 end;
3584 end;
3585
FindFileAtCursornull3586 function TFindDeclarationTool.FindFileAtCursor(
3587 const CursorPos: TCodeXYPosition; out Found: TFindFileAtCursorFlag; out
3588 FoundFilename: string; SearchFor: TFindFileAtCursorFlags;
3589 StartPos: PCodeXYPosition): boolean;
3590 var
3591 CleanPos: integer;
3592
3593 function CheckComment(CommentStart, CommentEnd: integer; Enabled: boolean): boolean;
3594 var
3595 DirectiveName, Param: string;
3596 NewCode: TCodeBuffer;
3597 MissingIncludeFile: TMissingIncludeFile;
3598 NewCodePtr: Pointer;
3599 begin
3600 Result:=false;
3601 // cursor in comment in parsed code
3602 {$IFDEF VerboseFindFileAtCursor}
3603 debugln(['TFindDeclarationTool.FindFileAtCursor.CheckComment']);
3604 {$ENDIF}
3605 if CommentStart=CommentEnd then exit;
3606 if ExtractLongParamDirective(Src,CommentStart,DirectiveName,Param) then begin
3607 DirectiveName:=lowercase(DirectiveName);
3608 if ((Enabled and (ffatIncludeFile in SearchFor))
3609 or (not Enabled and (ffatDisabledIncludeFile in SearchFor)))
3610 and (DirectiveName='i') or (DirectiveName='include')
3611 then begin
3612 // include directive
3613 if (Param<>'') and (Param[1]<>'%') then begin
3614 // include file directive
3615 Result:=true;
3616 if Enabled then
3617 Found:=ffatIncludeFile
3618 else
3619 Found:=ffatDisabledIncludeFile;
3620 if Enabled and IsIncludeDirectiveAtPos(CleanPos,CommentStart,NewCode) then
3621 begin
3622 FoundFilename:=NewCode.Filename;
3623 end else begin
3624 FoundFilename:=ResolveDots(GetForcedPathDelims(Param));
3625 // search include file
3626 MissingIncludeFile:=nil;
3627 if Scanner.SearchIncludeFile(FoundFilename,NewCodePtr,
3628 MissingIncludeFile)
3629 then
3630 FoundFilename:=TCodeBuffer(NewCodePtr).Filename;
3631 end;
3632 exit;
3633 end;
3634 end else if ((Enabled and (ffatResource in SearchFor))
3635 or (not Enabled and (ffatDisabledResource in SearchFor)))
3636 and ((DirectiveName='r') or (DirectiveName='resource'))
3637 then begin
3638 // resource directive
3639 Result:=true;
3640 if Enabled then
3641 Found:=ffatResource
3642 else
3643 Found:=ffatDisabledResource;
3644 FoundFilename:=ResolveDots(GetForcedPathDelims(Param));
3645 if (FoundFilename<>'') and (copy(FoundFilename,1,2)='*.') then begin
3646 Delete(FoundFilename,1,1);
3647 FoundFilename:=ChangeFileExt(MainFilename,FoundFilename);
3648 end else if not FilenameIsAbsolute(FoundFilename) then begin
3649 FoundFilename:=ResolveDots(ExtractFilePath(MainFilename)+FoundFilename);
3650 end;
3651 exit;
3652 end;
3653 end;
3654 end;
3655
3656 function CheckPlainComments(Source: string; CurAbsPos: integer): boolean;
3657 var
3658 Filename: String;
3659 p, EndPos, FileStartPos, FileEndPos, MinPos, MaxPos: Integer;
3660 begin
3661 // check if cursor in a comment (ignoring directives)
3662 Result:=false;
3663 CursorPos.Code.LineColToPosition(CursorPos.Y,CursorPos.X,CurAbsPos);
3664 Source:=CursorPos.Code.Source;
3665 if (CurAbsPos<1) or (CurAbsPos>length(Source)) then exit;
3666 p:=1;
3667 repeat
3668 p:=FindNextComment(Source,p);
3669 if p>CurAbsPos then break;
3670 EndPos:=FindCommentEnd(Source,p,Scanner.NestedComments);
3671 if EndPos>CurAbsPos then begin
3672 // cursor in comment
3673 MinPos:=p+1;
3674 MaxPos:=EndPos-1;
3675 if Source[p]<>'{' then begin
3676 inc(MinPos);
3677 dec(MaxPos);
3678 end;
3679 FileStartPos:=CurAbsPos;
3680 while (FileStartPos>MinPos) and not (Source[FileStartPos-1] in [#0..#32]) do
3681 dec(FileStartPos);
3682 FileEndPos:=CurAbsPos;
3683 while (FileEndPos<MaxPos) and not (Source[FileEndPos] in [#0..#32]) do
3684 inc(FileEndPos);
3685 Filename:=TrimFilename(copy(Source,FileStartPos,FileEndPos-FileStartPos));
3686 if not FilenameIsAbsolute(Filename) then
3687 Filename:=ResolveDots(ExtractFilePath(MainFilename)+Filename);
3688 if Scanner.OnLoadSource(Scanner,Filename,false)<>nil then begin
3689 Found:=ffatComment;
3690 FoundFilename:=Filename;
3691 exit(true);
3692 end;
3693 exit;
3694 end;
3695 p:=EndPos;
3696 until false;
3697 end;
3698
3699 function CheckUnitByWordAtCursor(Source: string; CurAbsPos: integer): boolean;
3700 // e.g. 'Sy|sUtils.CompareText'
3701 var
3702 AnUnitName: String;
3703 Code: TCodeBuffer;
3704 p: Integer;
3705 begin
3706 Result:=false;
3707 p:=FindStartOfAtom(Source,CurAbsPos);
3708 if p<1 then exit;
3709 AnUnitName:=GetIdentifier(@Source[p]);
3710 Code:=FindUnitSource(AnUnitName,'',false);
3711 if Code=nil then exit;
3712 Found:=ffatUnit;
3713 FoundFilename:=Code.Filename;
3714 Result:=true;
3715 end;
3716
3717 var
3718 CommentStart, CommentEnd, Col, StartCol, CurAbsPos: integer;
3719 Node: TCodeTreeNode;
3720 aUnitName, UnitInFilename, Line, Literal, aSource: string;
3721 NewCode: TCodeBuffer;
3722 p, StartP: PChar;
3723 begin
3724 {$IFDEF VerboseFindFileAtCursor}
3725 debugln(['TFindDeclarationTool.FindFileAtCursor START']);
3726 {$ENDIF}
3727 Result:=false;
3728 Found:=ffatNone;
3729 FoundFilename:='';
3730 if StartPos<>nil then
3731 StartPos^:=CleanCodeXYPosition;
3732 if CursorPos.Code.LineColIsOutside(CursorPos.Y,CursorPos.X) then begin
3733 {$IFDEF VerboseFindFileAtCursor}
3734 debugln(['TFindDeclarationTool.FindFileAtCursor LineColIsOutside ',dbgs(CursorPos)]);
3735 {$ENDIF}
3736 exit;
3737 end;
3738 if CursorPos.Code.LineColIsSpace(CursorPos.Y,CursorPos.X) then begin
3739 {$IFDEF VerboseFindFileAtCursor}
3740 debugln(['TFindDeclarationTool.FindFileAtCursor LineColIsSpace ',dbgs(CursorPos)]);
3741 {$ENDIF}
3742 exit;
3743 end;
3744 if (CursorPos.Y<1) or (CursorPos.Y>CursorPos.Code.LineCount) then begin
3745 {$IFDEF VerboseFindFileAtCursor}
3746 debugln(['TFindDeclarationTool.FindFileAtCursor outside Line ',dbgs(CursorPos)]);
3747 {$ENDIF}
3748 exit;
3749 end;
3750 if [ffatUsedUnit,ffatIncludeFile,ffatDisabledIncludeFile]*SearchFor<>[]
3751 then begin
3752 try
3753 {$IFDEF VerboseFindFileAtCursor}
3754 debugln(['TFindDeclarationTool.FindFileAtCursor search in nodes']);
3755 {$ENDIF}
3756 BuildTreeAndGetCleanPos(trTillCursor,lsrEnd,CursorPos,CleanPos,
3757 [btSetIgnoreErrorPos,btCursorPosOutAllowed]);
3758 Node:=FindDeepestNodeAtPos(CleanPos,false);
3759 {$IFDEF VerboseFindFileAtCursor}
3760 debugln(['TFindDeclarationTool.FindFileAtCursor has node: ',Node<>nil]);
3761 {$ENDIF}
3762 if Node<>nil then begin
3763 {$IFDEF VerboseFindFileAtCursor}
3764 debugln(['TFindDeclarationTool.FindFileAtCursor in node "',Node.DescAsString,'"']);
3765 {$ENDIF}
3766 // cursor in parsed code
3767 if CleanPosIsInComment(CleanPos,Node.StartPos,CommentStart,CommentEnd,true)
3768 then begin
3769 //debugln(['TFindDeclarationTool.FindFileAtCursor Comment="',copy(Src,CommentStart,CommentEnd-CommentStart),'"']);
3770 if (CommentEnd-CommentStart>4)
3771 and (Src[CommentStart]='{') and (Src[CommentStart+1]=#3) then begin
3772 // cursor in disabled code
3773 if CleanPosIsInComment(CleanPos,CommentStart+2,CommentStart,CommentEnd,true)
3774 then begin
3775 // cursor in disabled comment
3776 if CheckComment(CommentStart,CommentEnd,false) then
3777 exit(true);
3778 end;
3779 end else begin
3780 // cursor in enabled comment
3781 if CheckComment(CommentStart,CommentEnd,true) then
3782 exit(true);
3783 end;
3784 end else begin
3785 {$IFDEF VerboseFindFileAtCursor}
3786 debugln(['TFindDeclarationTool.FindFileAtCursor in parsed code, not in comment Node=',Node.DescAsString]);
3787 {$ENDIF}
3788 if Node.Desc in [ctnUseUnitClearName,ctnUseUnitNamespace] then begin
3789 Node:=Node.Parent;
3790 {$IFDEF VerboseFindFileAtCursor}
3791 debugln(['TFindDeclarationTool.FindFileAtCursor node="',Node.DescAsString,'"']);
3792 {$ENDIF}
3793 end;
3794 if Node.Desc=ctnUseUnit then begin
3795 {$IFDEF VerboseFindFileAtCursor}
3796 debugln(['TFindDeclarationTool.FindFileAtCursor in use unit CleanPos=',CleanPos,' Node=',Node.StartPos,'-',Node.EndPos]);
3797 {$ENDIF}
3798 if (CleanPos>=Node.StartPos) and (CleanPos<Node.EndPos) then begin
3799 // cursor on used unit
3800 Found:=ffatUsedUnit;
3801 if StartPos<>nil then
3802 CleanPosToCaret(Node.StartPos,StartPos^);
3803 MoveCursorToNodeStart(Node);
3804 ReadNextAtom;
3805 aUnitName:=ExtractUsedUnitNameAtCursor(@UnitInFilename);
3806 NewCode:=FindUnitSource(aUnitName,UnitInFilename,false);
3807 {$IFDEF VerboseFindFileAtCursor}
3808 debugln(['TFindDeclarationTool.FindFileAtCursor cursor on used unit "',aUnitName,'" in "',UnitInFilename,'" Found=',NewCode<>nil]);
3809 {$ENDIF}
3810 if NewCode<>nil then begin
3811 FoundFilename:=NewCode.Filename;
3812 Result:=true;
3813 end else begin
3814 FoundFilename:=UnitInFilename;
3815 Result:=false;
3816 end;
3817 exit;
3818 end;
3819 end;
3820 end;
3821 end;
3822 except
3823 on ELinkScannerError do ;
3824 on ECodeToolError do ;
3825 end;
3826 end;
3827
3828 // fallback: ignore parsed code and read the line at cursor directly
3829 if (CursorPos.Y<1) or (CursorPos.Y>CursorPos.Code.LineCount) then exit;
3830 Line:=CursorPos.Code.GetLine(CursorPos.Y-1,false);
3831 {$IFDEF VerboseFindFileAtCursor}
3832 debugln(['TFindDeclarationTool.FindFileAtCursor Line="',copy(Line,1,CursorPos.X-1),'|',copy(Line,CursorPos.X,200),'"']);
3833 {$ENDIF}
3834 if CursorPos.X>length(Line) then exit;
3835 if ffatLiteral in SearchFor then begin
3836 // check literal
3837 p:=PChar(Line);
3838 repeat
3839 case p^ of
3840 #0:
3841 break;
3842 '''':
3843 begin
3844 StartCol:=p-PChar(Line)+1;
3845 inc(p);
3846 StartP:=p;
3847 repeat
3848 case p^ of
3849 #0,'''': break;
3850 else inc(p);
3851 end;
3852 until false;
3853 Col:=p-PChar(Line)+1;
3854 //debugln(['TFindDeclarationTool.FindFileAtCursor Col=',Col,' CursorCol=',CursorPos.X,' Literal=',copy(Line,StartCol+1,p-StartP)]);
3855 if (p>StartP) and (CursorPos.X>=StartCol) and (CursorPos.X<=Col) then begin
3856 Literal:=copy(Line,StartCol+1,p-StartP);
3857 if not FilenameIsAbsolute(Literal) then
3858 Literal:=TrimFilename(ExtractFilePath(Scanner.MainFilename)+Literal);
3859 Found:=ffatLiteral;
3860 FoundFilename:=Literal;
3861 exit(true);
3862 end;
3863 if p^=#0 then break;
3864 // p is now on the ending '
3865 end;
3866 end;
3867 inc(p);
3868 inc(Col);
3869 until false;
3870 end;
3871
3872 // search without node tree with basic tools
3873 CursorPos.Code.LineColToPosition(CursorPos.Y,CursorPos.X,CurAbsPos);
3874 aSource:=CursorPos.Code.Source;
3875 if (CurAbsPos<1) or (CurAbsPos>length(aSource)) then exit;
3876
3877 if ffatComment in SearchFor then begin
3878 // ignore syntax and only read comments
3879 if CheckPlainComments(aSource,CurAbsPos) then exit(true);
3880 end;
3881
3882 if ffatUnit in SearchFor then begin
3883 if CheckUnitByWordAtCursor(aSource,CurAbsPos) then exit(true);
3884 end;
3885 end;
3886
FindDeclarationOfIdentAtParamnull3887 function TFindDeclarationTool.FindDeclarationOfIdentAtParam(
3888 Params: TFindDeclarationParams): boolean;
3889 var
3890 ExprType: TExpressionType;
3891 begin
3892 Result := FindDeclarationOfIdentAtParam(Params, ExprType) and (Params.NewNode<>nil);
3893 end;
3894
FindDeclarationOfIdentAtParamnull3895 function TFindDeclarationTool.FindDeclarationOfIdentAtParam(
3896 Params: TFindDeclarationParams; out ExprType: TExpressionType): boolean;
3897 { searches an identifier in clean code, parses code in front and after the
3898 identifier
3899
3900 Params:
3901 Identifier in clean source
3902 ContextNode // = DeepestNode at Cursor
3903
3904 Result:
3905 true, if found
3906
3907 Examples:
3908 A^.B().C[].Identifier
3909 inherited Identifier(p1,p2)
3910 'Hello'.identifier
3911 }
3912 var
3913 StartPos, EndPos: integer;
3914 SkipForward: boolean;
3915 begin
3916 {$IFDEF CTDEBUG}
3917 DebugLn('[TFindDeclarationTool.FindDeclarationOfIdentAtParam] Identifier=',
3918 '"',GetIdentifier(Params.Identifier),'"',
3919 ' ContextNode=',NodeDescriptionAsString(Params.ContextNode.Desc),
3920 ' "',dbgstr(copy(Src,Params.ContextNode.StartPos,20)),'"');
3921 {$ENDIF}
3922 Result:=false;
3923 // search in cleaned source
3924
3925 MoveCursorToCleanPos(Params.Identifier);
3926 StartPos:=FindStartOfTerm(CurPos.StartPos,NodeTermInType(Params.ContextNode));
3927 MoveCursorToCleanPos(Params.Identifier);
3928 ReadNextAtom;
3929 EndPos:=CurPos.EndPos;
3930 if (Params.ContextNode.Desc=ctnIdentifier)
3931 and (Params.ContextNode.Parent.Desc=ctnAttribParam) then begin
3932 // parameters don't matter for the attribute name
3933 end else begin
3934 ReadNextAtom;
3935 if CurPos.Flag=cafRoundBracketOpen then begin
3936 ReadTilBracketClose(true);
3937 EndPos:=CurPos.EndPos;
3938 end;
3939 end;
3940 {$IFDEF ShowExprEval}
3941 debugln(['TFindDeclarationTool.FindDeclarationOfIdentAtParam Term=',dbgstr(Src,StartPos,EndPos-StartPos)]);
3942 {$ENDIF}
3943 SkipForward:=fdfSkipClassForward in Params.Flags;
3944 Include(Params.Flags,fdfFindVariable);
3945 ExprType:=FindExpressionTypeOfTerm(StartPos,EndPos,Params,false);
3946 if (ExprType.Desc=xtContext) then
3947 Params.SetResult(ExprType.Context)
3948 else
3949 Params.SetResult(CleanFindContext);
3950 if SkipForward and (Params.NewNode<>nil) then
3951 Params.NewCodeTool.FindNonForwardClass(Params);
3952 {$IFDEF ShowExprEval}
3953 DbgOut('[TFindDeclarationTool.FindDeclarationOfIdentAtParam] Ident=',
3954 '"',GetIdentifier(Params.Identifier),'" ');
3955 if Params.NewNode<>nil then
3956 DebugLn('Node=',Params.NewNode.DescAsString,' ',Params.NewCodeTool.MainFilename)
3957 else
3958 DebugLn('NOT FOUND');
3959 {$ENDIF}
3960 Result:=ExprType.Desc<>xtNone;
3961 end;
3962
TFindDeclarationTool.IdentifierIsDefinednull3963 function TFindDeclarationTool.IdentifierIsDefined(const IdentAtom: TAtomPosition;
3964 ContextNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean;
3965 var
3966 Identifier: PChar;
3967 Node: TCodeTreeNode;
3968 begin
3969 {$IFDEF CheckNodeTool}CheckNodeTool(ContextNode);{$ENDIF}
3970 // find declaration of identifier
3971 Identifier:=@Src[IdentAtom.StartPos];
3972 //DebugLn(['TFindDeclarationTool.IdentifierIsDefined BEGIN Params IdentAtom.StartPos=',IdentAtom.StartPos,'=',GetIdentifier(Identifier),', ContextNode.StartPos=',ContextNode.StartPos,'=',ContextNode.DescAsString,' "',ExtractNode(ContextNode,[]),'"']);
3973 if (CompareIdentifiers(Identifier,'Self')=0) then begin
3974 Node:=ContextNode;
3975 while (Node<>nil) do begin
3976 if NodeIsMethodBody(Node) then
3977 exit(true);
3978 Node:=Node.Parent;
3979 end;
3980 end;
3981 if (cmsResult in FLastCompilerModeSwitches)
3982 and (CompareIdentifiers(Identifier,'Result')=0) then begin
3983 Node:=ContextNode;
3984 while (Node<>nil) do begin
odenull3985 if NodeIsFunction(Node) then
3986 exit(true);
3987 Node:=Node.Parent;
3988 end;
3989 end;
3990 Params.ContextNode:=ContextNode;
3991 Params.SetIdentifier(Self,Identifier,nil);
3992 Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors,fdfSearchInHelpers,
3993 fdfTopLvlResolving,fdfFindVariable,fdfIgnoreCurContextNode];
3994 Result:=FindIdentifierInContext(Params);
3995 //DebugLn(['TFindDeclarationTool.IdentifierIsDefined END Result=',Result]);
3996 end;
3997
TFindDeclarationTool.FindIdentifierInContextnull3998 function TFindDeclarationTool.FindIdentifierInContext(
3999 Params: TFindDeclarationParams; var IdentFoundResult: TIdentifierFoundResult
4000 ): boolean;
4001 { searches an identifier in context node
4002 It does not care about code in front of the identifier like 'a.Identifier'.
4003
4004 Params:
4005 Identifier
4006 ContextNode // = DeepestNode at Cursor
4007
4008 Result:
4009 true, if NewPos+NewTopLine valid
4010 }
4011 var
4012 LastContextNode, StartContextNode, FirstSearchedNode, LastSearchedNode,
4013 ContextNode: TCodeTreeNode;
4014 IsForward: boolean;
4015 IdentifierFoundResult: TIdentifierFoundResult;
4016 LastNodeCache: TCodeTreeNodeCache;
4017 LastCacheEntry: PCodeTreeNodeCacheEntry;
4018 SearchRangeFlags: TNodeCacheEntryFlags;
4019 NodeCacheEntryFlags: TNodeCacheEntryFlags;
4020 Flags: TFindDeclarationFlags;
4021 OldFlags: TFindDeclarationFlags;
4022 SearchInHelpersInTheEnd: Boolean;
4023
4024 procedure InitNodesAndCacheAccess;
4025
4026 procedure RaiseInternalError;
4027 begin
4028 RaiseException(20170421200059,'[TFindDeclarationTool.FindIdentifierInContext] '
4029 +' internal error: Params.ContextNode=nil');
4030 end;
4031
4032 begin
4033 ContextNode:=Params.ContextNode;
4034 if ContextNode=nil then RaiseInternalError;
4035 {$IFDEF CheckNodeTool}
4036 CheckNodeTool(ContextNode);
4037 {$ENDIF}
4038 StartContextNode:=ContextNode;
4039 FirstSearchedNode:=nil;
4040 LastSearchedNode:=nil;
4041 SearchRangeFlags:=[];
4042 Flags:=Params.Flags;
4043 if fdfSearchInParentNodes in Flags then
4044 Include(SearchRangeFlags,ncefSearchedInParents);
4045 if fdfSearchInAncestors in Flags then
4046 Include(SearchRangeFlags,ncefSearchedInAncestors);
4047 LastNodeCache:=nil;
4048 LastCacheEntry:=nil;
4049 NodeCacheEntryFlags:=[];
4050 if fdfSearchInParentNodes in Flags then
4051 Include(NodeCacheEntryFlags,ncefSearchedInParents);
4052 if fdfSearchInAncestors in Flags then
4053 Include(NodeCacheEntryFlags,ncefSearchedInAncestors);
4054 end;
4055
FindInNodeCachenull4056 function FindInNodeCache: boolean;
4057 var
4058 NodeCache: TCodeTreeNodeCache;
4059 begin
4060 Result:=false;
4061 // the node cache is identifier based
4062 if ([fdfCollect,fdfExtractOperand]*Flags<>[]) then exit;
4063
4064 NodeCache:=GetNodeCache(ContextNode,false);
4065 if (NodeCache<>LastNodeCache) then begin
4066 // NodeCache changed -> search nearest cache entry for the identifier
4067 LastNodeCache:=NodeCache;
4068 if NodeCache<>nil then begin
4069 LastCacheEntry:=NodeCache.FindNearest(Params.Identifier,
4070 ContextNode.StartPos,ContextNode.EndPos,
4071 not (fdfSearchForward in Flags));
4072 end else
4073 LastCacheEntry:=nil;
4074 end;
4075 if (LastCacheEntry<>nil)
4076 and (LastCacheEntry^.CleanStartPos<=ContextNode.StartPos)
4077 and (LastCacheEntry^.CleanEndPos>=ContextNode.EndPos)
4078 and ((NodeCacheEntryFlags-LastCacheEntry^.Flags)=[])
4079 then begin
4080 // cached result found
4081 Params.SetResult(LastCacheEntry);
4082 {$IFDEF ShowNodeCache}
4083 DbgOut(':::: TFindDeclarationTool.FindIdentifierInContext.FindInNodeCache');
4084 DebugLn(' Ident=',GetIdentifier(Params.Identifier),
4085 ' Wanted=[',NodeCacheEntryFlagsAsString(NodeCacheEntryFlags),']',
4086 ' Cache=[',NodeCacheEntryFlagsAsString(LastCacheEntry^.Flags),']'
4087 );
4088 DebugLn(' ContextNode=',ContextNode.DescAsString,
4089 ' StartPos=',DbgS(ContextNode.StartPos),
4090 ' EndPos=',DbgS(ContextNode.EndPos),
4091 ' Self=',MainFilename);
4092 DebugLn(' LastCacheEntry(Pos=',DbgS(LastCacheEntry^.CleanStartPos),
4093 '-',DbgS(LastCacheEntry^.CleanEndPos),')');
4094 if (Params.NewNode<>nil) then
4095 DebugLn(' NewTool=',Params.NewCodeTool.MainFilename,
4096 ' NewNode=',Params.NewNode.DescAsString)
4097 else
4098 DebugLn(' cache says: identifier does NOT exist');
4099 if CompareSrcIdentifiers(Params.Identifier,'TDefineAction') then begin
4100 NodeCache.WriteDebugReport('NANUNANA: ');
4101 end;
4102 {$ENDIF}
4103 Result:=true;
4104 end;
4105 end;
4106
4107 procedure CacheResult(Found: boolean; EndNode: TCodeTreeNode);
4108 begin
4109 if not Found then exit;
4110 FindIdentifierInContext:=true;
4111 {$IFDEF ShowCollect}
4112 if fdfCollect in Flags then
4113 raise Exception.Create('fdfCollect must never return true');
4114 {$ENDIF}
4115 {$IFDEF ShowFoundIdentifier}
4116 debugln(['CacheResult FOUND ',GetIdentifier(Params.Identifier)]);
4117 Params.WriteDebugReport;
4118 {$ENDIF}
4119 if (FirstSearchedNode=nil) then exit;
4120 if ([fdfDoNotCache,fdfCollect,fdfExtractOperand]*Flags<>[]) then exit;
4121 if ([fodDoNotCache]*Params.NewFlags<>[]) then exit;
4122 if (Params.OnIdentifierFound<>@CheckSrcIdentifier) then exit;
4123 if (Params.FoundProc<>nil) then exit; // do not cache proc searches
4124 // cache result
4125 if (Params.NewNode<>nil) and (Params.NewNode.Desc=ctnProcedure) then begin
4126 DebugLn('NOTE: TFindDeclarationTool.FindIdentifierInContext.CacheResult Node is proc');
4127 // ToDo:
4128 // The search range is from start to end of search.
4129 // This does not work for overloaded procs.
4130 // -> do not cache
4131 exit;
4132 end;
4133 AddResultToNodeCaches(FirstSearchedNode,EndNode,
4134 fdfSearchForward in Flags,Params,SearchRangeFlags);
4135 end;
4136
CheckResultnull4137 function CheckResult(NewResult, CallOnIdentifierFound: boolean): boolean;
4138 // returns: true to stop search
4139 // false if search should continue
4140
4141 procedure RaiseNotFound;
4142 var
4143 Identifier: string;
4144 begin
4145 Identifier:=GetIdentifier(Params.Identifier);
4146 if (Identifier='') and (Params.Identifier<>nil)
4147 and (Params.Identifier[0]<>#0) then begin
4148 Identifier:=Params.Identifier[0];
4149 if Identifier='[' then begin
4150 Params.IdentifierTool.RaiseException(20170421200103,ctsDefaultPropertyNotFound);
4151 end;
4152 end;
4153 Params.IdentifierTool.RaiseExceptionFmt(20170421200105,ctsIdentifierNotFound,
4154 [Identifier]);
4155 end;
4156
4157 begin
4158 Result:=true;
4159 FindIdentifierInContext:=NewResult and (not (fdfCollect in Flags));
4160 {$IFDEF ShowCollect}
4161 if fdfCollect in Flags then begin
4162 DebugLn('[TFindDeclarationTool.FindIdentifierInContext.CheckResult] COLLECT CheckResult Ident=',
4163 '"',GetIdentifier(Params.Identifier),'"',
4164 ' File="',ExtractFilename(MainFilename)+'"',
4165 ' Flags=[',dbgs(Flags)+']',
4166 ' NewResult=',DbgS(NewResult),
4167 ' CallOnIdentifierFound=',DbgS(CallOnIdentifierFound));
4168 end;
4169 {$ENDIF}
4170 if NewResult then begin
4171 // identifier found
4172 {$IFDEF ShowFoundIdentifier}
4173 debugln(['CheckResult FOUND ',GetIdentifier(Params.Identifier)]);
4174 Params.WriteDebugReport;
4175 {$ENDIF}
4176
4177 if fdfExtractOperand in Flags then
4178 case Params.NewNode.Desc of
4179 ctnVarDefinition, ctnConstDefinition:
4180 with Params do
4181 AddOperandPart(GetIdentifier(@NewCodeTool.Src[NewNode.StartPos]));
4182 ctnProperty,ctnGlobalProperty:
4183 begin
4184 if fdfPropertyResolving in Flags then begin
4185 if not PropNodeIsTypeLess(Params.NewNode)
4186 and ReadTilGetterOfProperty(Params.NewNode) then begin
4187 // continue searching of getter
4188 Params.Identifier := @Src[CurPos.StartPos];
4189 end;
4190 ContextNode := Params.NewNode;
4191 Exit(False);
4192 end else
4193 Params.AddOperandPart(GetIdentifier(Params.Identifier));
4194 end;
4195 ctnProcedure:
4196 begin
4197 Params.AddOperandPart(ExtractProcName(Params.NewNode,[]));
4198 // ToDo: add default parameters
4199 end;
4200 end;
4201
4202 if CallOnIdentifierFound then begin
4203 {debugln(['[TFindDeclarationTool.FindIdentifierInContext.CheckResult] CallOnIdentifierFound Ident=',
4204 '"',GetIdentifier(Params.Identifier),'"',
4205 ' StartContext="',StartContextNode.DescAsString,'" "',copy(Src,StartContextNode.StartPos,20),'"',
4206 ' File="',ExtractFilename(MainFilename)+'"',
4207 ' Flags=[',dbgs(Flags),']'
4208 ]);}
4209
4210 IdentFoundResult:=Params.NewCodeTool.DoOnIdentifierFound(Params,
4211 Params.NewNode);
4212 {$IFDEF ShowProcSearch}
4213 DebugLn(['[TFindDeclarationTool.FindIdentifierInContext.CheckResult] DoOnIdentifierFound=',IdentifierFoundResultNames[IdentFoundResult]]);
4214 {$ENDIF}
4215 if (IdentFoundResult=ifrSuccess) then
4216 CacheResult(true,ContextNode);
4217 Result:=IdentFoundResult<>ifrProceedSearch;
4218 if IdentFoundResult<>ifrAbortSearch then exit;
4219 end else begin
4220 if fdfCollect in Flags then
4221 Result:=false;
4222 CacheResult(true,ContextNode);
4223 exit;
4224 end;
4225 end;
4226 if Params.FoundProc<>nil then begin
4227 // there was a proc,
4228 // either the search for the overloaded proc was unsuccessful
4229 // or the searched proc was found in a recursive sub search
4230 // -> return the found proc
4231 if Params.FoundProc^.CacheValid
4232 and (Params.FoundProc^.ProcCompatibility=tcExact) then begin
4233 // stop the search
4234 Result:=true;
4235 end;
4236 FindIdentifierInContext:=true;
4237 {$IFDEF ShowCollect}
4238 if fdfCollect in Flags then
4239 raise Exception.Create('fdfCollect must never return true');
4240 {$ENDIF}
4241 Params.SetResult(Params.FoundProc^.Context.Tool,
4242 Params.FoundProc^.Context.Node);
4243 {$IF defined(ShowProcSearch) or defined(ShowFoundIdentifier)}
4244 DebugLn('[TFindDeclarationTool.FindIdentifierInContext] PROC Search ended with only one proc (normal when searching every used unit):');
4245 Params.WriteDebugReport;
4246 {$ENDIF}
4247 exit;
4248 end;
4249 // identifier was not found
4250 if not (fdfExceptionOnNotFound in Flags) then exit;
4251 if (Params.Identifier<>nil)
4252 and not (fdfExceptionOnPredefinedIdent in Flags)
4253 and WordIsPredefinedIdentifier.DoItCaseInsensitive(Params.Identifier)
4254 then begin
4255 Params.SetResult(nil,nil);
4256 exit;
4257 end;
4258 // identifier was not found and exception is wanted
4259 // -> raise exception
4260 if Params.IdentifierTool.IsPCharInSrc(Params.Identifier) then
4261 Params.IdentifierTool.MoveCursorToCleanPos(Params.Identifier);
4262 RaiseNotFound;
4263 end;
4264
4265 procedure MoveContextNodeToChildren;
4266 begin
4267 if (ContextNode.LastChild<>nil) then begin
4268 if not (fdfSearchForward in Flags) then begin
4269 RaiseLastErrorIfInFrontOfCleanedPos(ContextNode.EndPos);
4270 ContextNode:=ContextNode.LastChild;
4271 end else
4272 ContextNode:=ContextNode.FirstChild;
4273 end;
4274 end;
4275
SearchInGenericParamsnull4276 function SearchInGenericParams(GenParamsNode: TCodeTreeNode): boolean;
4277 var
4278 Node: TCodeTreeNode;
4279 begin
4280 Result:=false;
4281 if (GenParamsNode=nil) or (GenParamsNode.Desc<>ctnGenericParams) then exit;
4282 Node:=GenParamsNode.FirstChild;
4283 while Node<>nil do begin
4284 if (fdfCollect in Flags)
4285 or CompareSrcIdentifiers(Node.StartPos,Params.Identifier)
4286 then begin
4287 {$IFDEF ShowTriedIdentifiers}
4288 DebugLn(' SearchInGenericParams Identifier found="',GetIdentifier(@Src[Node.StartPos]),'" at '+CleanPosToStr(Node.StartPos));
4289 {$ENDIF}
4290 // identifier found
4291 Params.SetResult(Self,Node);
4292 Result:=CheckResult(true,true);
4293 if not (fdfCollect in Flags) then
4294 exit;
4295 end;
4296 Node:=Node.NextBrother;
4297 end;
4298 end;
4299
SearchInTypeVarConstGlobPropDefinitionnull4300 function SearchInTypeVarConstGlobPropDefinition: boolean;
4301 // returns: true if ok to exit
4302 // false if search should continue
4303 var
4304 NameNode: TCodeTreeNode;
4305 begin
4306 Result:=false;
4307 NameNode:=ContextNode;
4308 if ContextNode.Desc=ctnGenericType then begin
4309 NameNode:=ContextNode.FirstChild;
4310 if NameNode=nil then exit;
4311 end;
4312
4313 if (fdfCollect in Flags)
4314 or CompareSrcIdentifiers(NameNode.StartPos,Params.Identifier)
4315 then begin
4316 {$IFDEF ShowTriedIdentifiers}
4317 DebugLn(' Definition Identifier found="',GetIdentifier(Params.Identifier),'"');
4318 {$ENDIF}
4319 // identifier found
4320 Params.SetResult(Self,ContextNode);
4321 Result:=CheckResult(true,true);
4322 if not (fdfCollect in Flags) then begin
4323 if (fdfSkipClassForward in Flags)
4324 and (ContextNode.FirstChild<>nil)
4325 and (ContextNode.FirstChild.Desc in AllClasses)
4326 and ((ctnsForwardDeclaration and ContextNode.FirstChild.SubDesc)<>0)
4327 then begin
4328 FindNonForwardClass(Params);
4329 end;
4330 exit;
4331 end;
4332 end;
4333 // search for enums
4334 Params.ContextNode:=ContextNode;
4335 if FindEnumInContext(Params) then begin
4336 Result:=CheckResult(true,false);
4337 end;
4338 end;
4339
SearchInGenericTypenull4340 function SearchInGenericType: boolean;
4341 // returns: true if ok to exit
4342 // false if search should continue
4343 var
4344 NameNode: TCodeTreeNode;
4345 begin
4346 Result:=false;
4347 NameNode:=ContextNode.FirstChild;
4348 if NameNode=nil then exit;
4349
4350 // try type name
4351 if (fdfCollect in Flags)
4352 or CompareSrcIdentifiers(NameNode.StartPos,Params.Identifier)
4353 then begin
4354 {$IFDEF ShowTriedIdentifiers}
4355 DebugLn(' Definition Identifier found="',GetIdentifier(Params.Identifier),'"');
4356 {$ENDIF}
4357 // identifier found
4358 Params.SetResult(Self,ContextNode);
4359 Result:=CheckResult(true,true);
4360 if not (fdfCollect in Flags) then begin
4361 if (fdfSkipClassForward in Flags)
4362 and (ContextNode.LastChild.Desc in AllClasses)
4363 and ((ctnsForwardDeclaration and ContextNode.LastChild.SubDesc)<>0)
4364 then begin
4365 FindNonForwardClass(Params);
4366 end;
4367 exit;
4368 end;
4369 end;
4370
4371 // search for enums
4372 Params.ContextNode:=ContextNode;
4373 if FindEnumInContext(Params) then begin
4374 Result:=CheckResult(true,false);
4375 end;
4376 end;
4377
SearchInTypeOfVarConstnull4378 function SearchInTypeOfVarConst: boolean;
4379 // returns: true if ok to exit
4380 // false if search should continue
4381 begin
4382 Result:=false;
4383 //debugln(['SearchInTypeOfVarConst ',ContextNode.Parent.DescAsString]);
4384 if (ContextNode.Parent.Desc in [ctnConstDefinition,ctnVarDefinition])
4385 and (Src[ContextNode.StartPos]='(') then
4386 begin
4387 if FindIdentifierInTypeOfConstant(ContextNode.Parent,Params) then begin
4388 Result:=CheckResult(true,false);
4389 end;
4390 end;
4391 end;
4392
SearchInEnumLabelDefinitionnull4393 function SearchInEnumLabelDefinition: boolean;
4394 // returns: true if ok to exit
4395 // false if search should continue
4396 begin
4397 Result:=false;
4398 if (fdfCollect in Flags)
4399 or CompareSrcIdentifiers(ContextNode.StartPos,Params.Identifier)
4400 then begin
4401 {$IFDEF ShowTriedIdentifiers}
4402 DebugLn(' Enum/Label Identifier found="',GetIdentifier(Params.Identifier),'"');
4403 {$ENDIF}
4404 // identifier found
4405 Params.SetResult(Self,ContextNode);
4406 Result:=CheckResult(true,true);
4407 if not (fdfCollect in Flags) then begin
4408 exit;
4409 end;
4410 end;
4411 end;
4412
SearchInOnBlockDefinitionnull4413 function SearchInOnBlockDefinition: boolean;
4414 begin
4415 Result:=false;
4416 if ContextNode.FirstChild=nil then exit;
4417 //debugln('SearchInOnBlockDefinition B ',GetIdentifier(@Src[ContextNode.StartPos]));
4418 if (fdfCollect in Flags)
4419 or CompareSrcIdentifiers(ContextNode.FirstChild.StartPos,Params.Identifier)
4420 then begin
4421 {$IFDEF ShowTriedIdentifiers}
4422 DebugLn(' ON Identifier found="',GetIdentifier(Params.Identifier),'"');
4423 {$ENDIF}
4424 // identifier found
4425 Params.SetResult(Self,ContextNode.FirstChild);
4426 Result:=CheckResult(true,true);
4427 if not (fdfCollect in Flags) then
4428 exit;
4429 end;
4430 end;
4431
SearchInSourceNamenull4432 function SearchInSourceName: boolean;
4433 // returns: true if ok to exit
4434 // false if search should continue
4435 var
4436 SrcNode: TCodeTreeNode;
4437 begin
4438 Result:=false;
4439 SrcNode:=Tree.Root;
4440 MoveCursorToNodeStart(SrcNode);
4441 ReadNextAtom; // read keyword
4442 if (SrcNode.Desc=ctnProgram) and (not UpAtomIs('PROGRAM')) then exit;
4443 ReadNextAtom; // read name
4444 if (fdfCollect in Flags)
4445 or CompareSrcIdentifiers(CurPos.StartPos,Params.Identifier) then
4446 begin
4447 // identifier found
4448 {$IFDEF ShowTriedIdentifiers}
4449 if not (fdfCollect in Flags) then
4450 DebugLn(' Source Name Identifier found="',GetIdentifier(Params.Identifier),'"');
4451 {$ENDIF}
4452 Params.SetResult(Self,SrcNode,CurPos.StartPos);
4453 Result:=CheckResult(true,true);
4454 if not (fdfCollect in Flags) then
4455 exit;
4456 end;
4457 end;
4458
SearchDefaultnull4459 function SearchDefault: boolean;
4460 begin
4461 Result:=false;
4462 if SearchInSourceName then
4463 exit(true);
4464 if (not (fdfIgnoreUsedUnits in Flags))
4465 and FindIdentifierInHiddenUsedUnits(Params) then begin
4466 Result:=CheckResult(true,false);
4467 end;
4468 end;
4469
SearchInPropertynull4470 function SearchInProperty: boolean;
4471 // search in ctnProperty, not ctnGlobalProperty
4472 // returns: true if ok to exit
4473 // false if search should continue
4474 begin
4475 Result:=false;
4476 if (fdfCollect in Flags)
4477 or (Params.Identifier[0]<>'[') then begin
4478 MoveCursorToNodeStart(ContextNode);
4479 ReadNextAtom; // read keyword 'property'
4480 if UpAtomIs('CLASS') then ReadNextAtom;
4481 ReadNextAtom; // read name
4482 if (fdfCollect in Flags)
4483 or CompareSrcIdentifiers(CurPos.StartPos,Params.Identifier) then begin
4484 // identifier found
4485 {$IFDEF ShowTriedIdentifiers}
4486 DebugLn(' Property Identifier found="',GetIdentifier(Params.Identifier),'"');
4487 {$ENDIF}
4488 Params.SetResult(Self,ContextNode,CurPos.StartPos);
4489 Result:=CheckResult(true,true);
4490 end;
4491 end else begin
4492 // the default property is searched
4493 if PropertyIsDefault(ContextNode) then begin
4494 Params.SetResult(Self,ContextNode);
4495 Result:=CheckResult(true,true);
4496 end;
4497 end;
4498 end;
4499
LeavingContextIsPermittednull4500 function LeavingContextIsPermitted: boolean;
4501 begin
4502 Result:=true;
4503 if (not ContextNode.HasAsParent(StartContextNode)) then begin
4504 // searching in a prior node, will leave the start context
4505 if (not (fdfSearchInParentNodes in Flags)) then begin
4506 // searching in any parent context is not permitted
4507 if not ((fdfSearchInAncestors in Flags)
4508 and (ContextNode.Desc in AllClasses)) then begin
4509 // even searching in ancestors contexts is not permitted
4510 // -> there is no prior context accessible any more
4511 // -> identifier not found
4512 {$IFDEF ShowTriedContexts}
4513 DebugLn('[TFindDeclarationTool.FindIdentifierInContext] no prior node accessible ',
4514 ' ContextNode=',ContextNode.DescAsString,
4515 ' "',StringToPascalConst(copy(Src,ContextNode.StartPos,15)),'"'
4516 );
4517 {$ENDIF}
4518 ContextNode:=nil;
4519 Result:=false;
4520 end;
4521 end;
4522 end;
4523 end;
4524
SearchInHelpersnull4525 function SearchInHelpers: Boolean;
4526 var
4527 HelperContext: TFindContext;
4528 Helpers: TFDHelpersList;
4529 HelperKind: TFDHelpersListKind;
4530 HelperIterator: TAVLTreeNode;
4531 begin
4532 Result := False;
4533 SearchInHelpersInTheEnd := False;
4534 if StartContextNode.Desc=ctnObjCClass then
4535 HelperKind:=fdhlkObjCCategory
4536 else
4537 HelperKind:=fdhlkDelphiHelper;
4538 Helpers:=Params.GetHelpers(HelperKind);
4539 if Helpers=nil then exit;
4540 if not Helpers.IterateFromClassNode(StartContextNode,Self,
4541 HelperContext,HelperIterator) then exit;
4542 //debugln(['SearchInHelpers START at least one helper found, iterating...']);
4543 //Helpers.WriteDebugReport;
4544 repeat
4545 //debugln(['SearchInHelpers searching in Helper=',FindContextToString(HelperContext),'...']);
4546 OldFlags := Params.Flags;
4547 try
4548 Params.Flags:=Params.Flags
4549 -[fdfExceptionOnNotFound,fdfIgnoreCurContextNode,fdfSearchInHelpers]
4550 +[fdfIgnoreUsedUnits];
4551 Params.ContextNode := HelperContext.Node;
4552
4553 if HelperContext.Tool.FindIdentifierInContext(Params, IdentFoundResult) then
4554 begin
4555 if (IdentFoundResult = ifrAbortSearch)
4556 or ((IdentFoundResult = ifrSuccess) and CheckResult(true,False))
4557 then
4558 Result := True;
4559 end;
4560 finally
4561 Params.Flags := OldFlags;
4562 end;
4563 until (HelperKind=fdhlkDelphiHelper) or (not Helpers.GetNext(HelperContext,HelperIterator));
4564 //debugln(['SearchInHelpers END']);
4565 end;
4566
SearchInNamespacesnull4567 function SearchInNamespaces(SourceNamespaceNode: TCodeTreeNode): Boolean;
4568 // SourceNamespaceNode.Desc = ctnUseUnitNamespace
4569 // search all use-unit nodes with the same namespace prefix as SourceNamespaceNode
4570 var
4571 UnitNode, ThisNamespaceNode, TargetNamespaceNode, UsesNode: TCodeTreeNode;
4572 Level, CurLevel: Integer;
4573 InFilename, AnUnitName, FoundNames, FoundName: String;
4574 NewCodeTool: TFindDeclarationTool;
4575 begin
4576 Result := False;
4577 if SourceNamespaceNode.Desc<>ctnUseUnitNamespace then
4578 RaiseException(20170426102058,'');
4579 //debugln(['SearchInNamespaces ',ExtractNode(SourceNamespaceNode.Parent,[]),' ',fdfCollect in Flags]);
4580 if not (fdfCollect in Flags) then begin
4581 // search a specific identifier within a use-unit name
4582 if (SourceNamespaceNode.NextBrother<>nil)
4583 and (
4584 (Params.Identifier=nil) or
4585 CompareSrcIdentifiers(SourceNamespaceNode.NextBrother.StartPos,Params.Identifier))
4586 then begin
4587 Params.SetResult(Self,SourceNamespaceNode.NextBrother);
4588 Result:=CheckResult(true,true);
4589 end;
4590 exit;
4591 end;
4592 // collect all uses-units with same namespace
4593
4594 UsesNode:=SourceNamespaceNode.Parent.Parent;
4595
4596 Level:=1;
4597 while SourceNamespaceNode.PriorBrother<>nil do begin
4598 inc(Level);
4599 SourceNamespaceNode:=SourceNamespaceNode.PriorBrother;
4600 end;
4601
4602 FoundNames:='';
4603 UnitNode := UsesNode.LastChild;
4604 while UnitNode<>nil do
4605 begin
4606 ThisNamespaceNode := SourceNamespaceNode;
4607 TargetNamespaceNode := UnitNode.FirstChild;
4608 CurLevel:=0;
4609 while (ThisNamespaceNode<>nil) and (TargetNamespaceNode<>nil) do
4610 begin
4611 if CompareIdentifierPtrs(
4612 @Src[ThisNamespaceNode.StartPos],
4613 @Src[TargetNamespaceNode.StartPos]) <> 0
4614 then Break;
4615 inc(CurLevel);
4616 if CurLevel=Level then break;
4617
4618 ThisNamespaceNode := ThisNamespaceNode.NextBrother;
4619 TargetNamespaceNode := TargetNamespaceNode.NextBrother;
4620 end;
4621 if CurLevel=Level then
4622 begin
4623 // namespace paths match
4624 //debugln(['SearchInNamespaces Match ',ExtractNode(TargetNamespaceNode.Parent,[])]);
4625 if (TargetNamespaceNode.NextBrother<>nil) then begin
4626 // prefix matches
4627 FoundName:='('+GetIdentifier(@Src[TargetNamespaceNode.NextBrother.StartPos])+')';
4628 if (Pos(FoundName,FoundNames)<1)
4629 and ((Params.Identifier=nil)
4630 or CompareSrcIdentifiers(TargetNamespaceNode.NextBrother.StartPos,Params.Identifier))
4631 then begin
4632 FoundNames:=FoundNames+FoundName;
4633 Params.SetResult(Self,TargetNamespaceNode.NextBrother);
4634 Result:=CheckResult(true,true);
4635 end;
4636 end else begin
4637 // whole unit name matches -> list all interface identifiers
4638 AnUnitName:=ExtractUsedUnitName(UnitNode,@InFilename);
4639 NewCodeTool:=FindCodeToolForUsedUnit(AnUnitName,InFilename,true);
4640 NewCodeTool.FindIdentifierInInterface(Params.IdentifierTool,Params);
4641 end;
4642 end;
4643
4644 if UnitNode.PriorBrother<>nil then
4645 UnitNode := UnitNode.PriorBrother
4646 else if UnitNode.Parent.Desc=ctnImplementation then begin
4647 UnitNode:=FindMainUsesNode;
4648 if UnitNode=nil then break;
4649 UnitNode:=UnitNode.LastChild;
4650 end else
4651 break;
4652 end;
4653 end;
4654
SearchNextNodenull4655 function SearchNextNode: boolean;
4656 const
4657 AbortNoCacheResult = false;
4658 Proceed = true;
4659 begin
4660 repeat
4661 // search for prior node
4662 {$IFDEF ShowTriedIdentifiers}
4663 DebugLn('[TFindDeclarationTool.FindIdentifierInContext.SearchNextNode] Searching prior node of ',ContextNode.DescAsString,' ',dbgstr(copy(Src,ContextNode.StartPos,ContextNode.EndPos-ContextNode.StartPos)));
4664 {$ENDIF}
4665 LastSearchedNode:=ContextNode;
4666
4667 if (ContextNode.Desc in AllClasses) then begin
4668 // after searching in a class definition ...
4669
4670 if (ContextNode.PriorBrother<>nil) and (ContextNode.PriorBrother.Desc=ctnGenericParams)
4671 then begin
4672 // before searching in the ancestors, search in the generic parameters
4673 if SearchInGenericParams(ContextNode.PriorBrother) then begin
4674 FindIdentifierInContext:=true;
4675 {$IFDEF ShowCollect}
4676 if fdfCollect in Flags then
4677 raise Exception.Create('fdfCollect must never return true');
4678 {$ENDIF}
4679 exit(AbortNoCacheResult);
4680 end;
4681 end;
4682
4683 //allow ctnRecordType and ctnTypeTypeBeforeHelper: they can have helpers!
4684 if (fdfSearchInAncestors in Flags) then begin
4685 // after searching in a class definition, search in its ancestors
4686 // ToDo: check for cycles in ancestors
4687
4688 OldFlags := Params.Flags;
4689 Params.Flags:=Params.Flags-[fdfExceptionOnNotFound,fdfSearchInHelpersInTheEnd];
4690
4691 // leaving current class -> check if search in helpers in the end
4692 if SearchInHelpersInTheEnd then
4693 begin
4694 Result := SearchInHelpers;
4695 Params.Flags := OldFlags;
4696 if Result then
4697 begin
4698 FindIdentifierInContext:=true;
4699 Exit(AbortNoCacheResult);
4700 end;
4701 end;
4702
4703 Exclude(Params.Flags,fdfExceptionOnNotFound);
4704 Result:=FindIdentifierInAncestors(ContextNode,Params,IdentFoundResult);
4705 Params.Flags := OldFlags;
4706 if Result then begin
4707 FindIdentifierInContext:=true;
4708 {$IFDEF ShowCollect}
4709 if fdfCollect in Flags then
4710 raise Exception.Create('fdfCollect must never return true');
4711 {$ENDIF}
4712 exit(AbortNoCacheResult);
4713 end;
4714 end;
4715 // if this was a nested class, the identifier can be in the ancestors
4716 // of the enclosing class
4717 Flags:=Flags+[fdfSearchInAncestors];
4718 end else if ContextNode.Desc=ctnClassInheritance then begin
4719 if (StartContextNode=ContextNode)
4720 or StartContextNode.HasAsParent(ContextNode) then
4721 // searching an ancestor => don't search within ancestors
4722 Exclude(Flags,fdfSearchInAncestors);
4723 end;
4724
4725 if (ContextNode=StartContextNode)
4726 and (not (fdfSearchInParentNodes in Flags)) then begin
4727 // startcontext completed => not searching in parents or ancestors
4728 ContextNode:=nil;
4729 exit(Proceed);
4730 end;
4731
4732 if ((not (fdfSearchForward in Flags))
4733 and (ContextNode.PriorBrother<>nil))
4734 or ((fdfSearchForward in Flags)
4735 and (ContextNode.NextBrother<>nil)
4736 and (ContextNode.NextBrother.Desc<>ctnImplementation)) then
4737 begin
4738 // search next in prior/next brother
4739 if not (fdfSearchForward in Flags) then
4740 ContextNode:=ContextNode.PriorBrother
4741 else begin
4742 RaiseLastErrorIfInFrontOfCleanedPos(ContextNode.NextBrother.EndPos);
4743 ContextNode:=ContextNode.NextBrother;
4744 end;
4745 {$IFDEF ShowTriedIdentifiers}
4746 DebugLn('[TFindDeclarationTool.FindIdentifierInContext] Searching in Brother ContextNode=',ContextNode.DescAsString);
4747 {$ENDIF}
4748 // it is not always allowed to search in every node on the same lvl:
4749
4750 // -> test if class visibility valid
4751 if ContextNode.Desc in AllClassSections then
4752 break
4753 else if ContextNode.Desc=ctnWithVariable then begin
4754 { check if StartContextNode is covered by the ContextNode
4755 a WithVariable ranges from the start of its expression
4756 to the end of the with statement
4757 for example:
4758 will be skipped:
4759 with ContextNode do ;
4760 with B do StartContextNode;
4761
4762 will be searched:
4763 with ContextNode, StartContextNode do ;
4764 }
4765 {$IFDEF ShowExprEval}
4766 DebugLn('SearchNextNode WithVar StartContextNode.StartPos=',dbgs(StartContextNode.StartPos),
4767 ' ContextNode=',dbgs(ContextNode.StartPos),'-',dbgs(ContextNode.EndPos),
4768 ' WithStart=',StringToPascalConst(
4769 copy(copy(Src,ContextNode.StartPos,ContextNode.EndPos-ContextNode.StartPos),1,50)));
4770 {$ENDIF}
4771 if (StartContextNode.StartPos>=ContextNode.StartPos)
4772 and (StartContextNode.StartPos<ContextNode.EndPos) then begin
4773 {$IFDEF ShowExprEval}
4774 debugln(['SearchNextNode WithVar covers startcontext']);
4775 {$ENDIF}
4776 // for example: with ContextNode, StartContextNode do ;
4777 break;
4778 end else begin
4779 // this with statement does not cover the startcontext. For instance:
4780 // with ContextNode do ;
4781 // with B do StartContextNode;
4782 // -> skip it
4783 end;
4784 end else if ContextNode.Desc=ctnOnBlock then begin
4785 // the ctnOnIdentifier is only valid within the ctnOnStatement
4786 // => skip
4787 end else begin
4788 break;
4789 end;
4790 end else if (ContextNode.Parent<>nil)
4791 and ((fdfSearchInParentNodes in Flags)
4792 or (ContextNode.HasAsParent(StartContextNode))) then
4793 begin
4794 // search next in parent
4795 {$IFDEF ShowTriedParentContexts}
4796 DebugLn('[TFindDeclarationTool.FindIdentifierInContext] Searching in Parent ',
4797 ' old ContextNode=',ContextNode.DescAsString,
4798 ' new ContextNode=',ContextNode.Parent.DescAsString
4799 );
4800 {$ENDIF}
4801 ContextNode:=ContextNode.Parent;
4802
4803 case ContextNode.Desc of
4804
4805 ctnTypeSection, ctnVarSection, ctnConstSection, ctnResStrSection,
4806 ctnLabelSection, ctnPropertySection,
4807 ctnInterface, ctnImplementation, ctnProgram, ctnLibrary,
4808 ctnClassPublished,ctnClassPublic,ctnClassProtected,ctnClassPrivate,
4809 ctnClassClassVar,
4810 ctnRecordVariant,
4811 ctnProcedureHead, ctnParameterList,
4812 ctnClassInheritance,ctnHelperFor:
4813 // these codetreenodes build a parent-child-relationship, but
4814 // for pascal it is only a range, hence after searching in the
4815 // children of the last node, search must continue in the children
4816 // of the prior node
4817 ;
4818
4819 ctnClass, ctnClassInterface, ctnDispinterface, ctnObject,
4820 ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass,
4821 ctnRecordType, ctnRecordCase,
4822 ctnClassHelper, ctnRecordHelper, ctnTypeHelper,
4823 ctnEnumerationType:
4824 // do not search again in this node, go on ...
4825 ;
4826
4827 ctnVarDefinition, ctnConstDefinition:
4828 if (ContextNode.Parent<>nil)
4829 and (ContextNode.Parent.Desc=ctnParameterList) then begin
4830 // pascal allows declarations like: 'var a: a;' in parameters
4831 // -> skip variable and search in next context node
4832 ;
4833 end else begin
4834 break;
4835 end;
4836
4837 ctnProcedure:
4838 begin
4839 Result:=FindIdentifierInClassOfMethod(ContextNode,Params);
4840 if Result then begin
4841 FindIdentifierInContext:=true;
4842 {$IFDEF ShowCollect}
4843 if fdfCollect in Flags then
4844 raise Exception.Create('fdfCollect must never return true');
4845 {$ENDIF}
4846 exit(AbortNoCacheResult);
4847 end;
4848 end;
4849
4850 else
4851 break;
4852 end;
4853 end else begin
4854 ContextNode:=nil;
4855 break;
4856 end;
4857 until false;
4858 Result:=Proceed;
4859 end;
4860
4861 begin
4862 Result:=false;
4863 InitNodesAndCacheAccess;
4864
4865 {$IFDEF ShowTriedContexts}
4866 DebugLn('[TFindDeclarationTool.FindIdentifierInContext] Start Ident=',
4867 '"'+GetIdentifier(Params.Identifier)+'"',
4868 ' Context="'+ContextNode.DescAsString+'" "'+StringToPascalConst(copy(Src,ContextNode.StartPos,20)),'"',
4869 ' at '+CleanPosToStr(ContextNode.StartPos,true),
4870 ' Flags=['+dbgs(Flags)+']'
4871 );
4872 {$ELSE}
4873 {$IFDEF ShowCollect}
4874 if fdfCollect in Flags then begin
4875 DebugLn(['[TFindDeclarationTool.FindIdentifierInContext] COLLECT Start Ident=',
4876 '"',GetIdentifier(Params.Identifier),'"',
4877 ' Context="',ContextNode.DescAsString,'" "',copy(Src,ContextNode.StartPos,20),'"',
4878 ' at '+CleanPosToStr(ContextNode.StartPos,true),
4879 ' Flags=[',dbgs(Flags),']'
4880 ]);
4881 end;
4882 {$ENDIF}
4883 {$ENDIF}
4884
4885 if (ContextNode.Desc=ctnInterface)
4886 and (fdfIgnoreUsedUnits in Flags) then begin
4887 {$IFDEF ShowTriedContexts}
4888 DebugLn(['TFindDeclarationTool.FindIdentifierInContext searching in interface of ',MainFilename]);
4889 {$ENDIF}
4890 Result:=FindIdentifierInInterface(Params.IdentifierTool,Params);
4891 CheckResult(Result,false);
4892 exit;
4893 end;
4894
4895 if (ContextNode.Desc=ctnUseUnitNamespace) then
4896 begin
4897 //search in namespaces
4898 //debugln(['TFindDeclarationTool.FindIdentifierInContext NameSpace ',GetIdentifier(Params.Identifier),' ',ExtractNode(ContextNode,[])]);
4899 if SearchInNamespaces(ContextNode) then exit;
4900 Exit;
4901 end;
4902
4903 // find class helper functions
4904 SearchInHelpersInTheEnd := False;
4905 if (fdfSearchInHelpers in Flags)
4906 and (ContextNode.Desc in [ctnClass,ctnRecordType,ctnTypeType,ctnObjCClass,ctnEnumerationType,ctnRangedArrayType,ctnOpenArrayType])
4907 and (ContextNode.Parent<>nil) and (ContextNode.Parent.Desc = ctnTypeDefinition)
4908 then begin
4909 if (fdfSearchInHelpersInTheEnd in Flags) then
4910 SearchInHelpersInTheEnd := True
4911 else begin
4912 if SearchInHelpers then Exit;
4913 end;
4914 end;
4915
4916 //try
4917 // search in the Tree of this tool
4918 repeat
4919 {$IFDEF ShowTriedIdentifiers}
4920 DebugLn('[TFindDeclarationTool.FindIdentifierInContext] Loop Ident=',
4921 '"',GetIdentifier(Params.Identifier),'"',
4922 ' Context="',ContextNode.DescAsString,'" "',copy(Src,ContextNode.StartPos,20),'"',
4923 ' Flags=[',dbgs(Flags),']'
4924 );
4925 {$ELSE}
4926 {$IFDEF ShowCollect}
4927 if fdfCollect in Flags then begin
4928 DebugLn('[TFindDeclarationTool.FindIdentifierInContext] COLLECT Loop Ident=',
4929 '"',GetIdentifier(Params.Identifier),'"',
4930 ' Context="',ContextNode.DescAsString,'" "',copy(Src,ContextNode.StartPos,20),'"',
4931 ' Flags=[',dbgs(Flags),']'
4932 );
4933 end;
4934 {$ENDIF}
4935 {$ENDIF}
4936 // search identifier in current context
4937 LastContextNode:=ContextNode;
4938 if not (fdfIgnoreCurContextNode in Flags) then begin
4939 // search in cache
4940 if FindInNodeCache then begin
4941 if CheckResult(Params.NewNode<>nil,Params.NewNode<>nil) then
4942 exit;
4943 end;
4944 if FirstSearchedNode=nil then FirstSearchedNode:=ContextNode;
4945 LastSearchedNode:=ContextNode;
4946
4947 case ContextNode.Desc of
4948
4949 ctnTypeSection, ctnVarSection, ctnConstSection, ctnResStrSection,
4950 ctnLabelSection, ctnPropertySection,
4951 ctnInterface, ctnImplementation,
4952 ctnProgram, ctnLibrary,
4953 ctnClassPublic, ctnClassPrivate, ctnClassProtected, ctnClassPublished,
4954 ctnClassClassVar,
4955 ctnClass, ctnClassInterface, ctnDispinterface, ctnObject,
4956 ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass,
4957 ctnRecordType, ctnRecordVariant,
4958 ctnClassHelper, ctnRecordHelper, ctnTypeHelper,
4959 ctnEnumerationType,
4960 ctnParameterList:
4961 // these nodes build a parent-child relationship. But in pascal
4962 // they just define a range and not a context.
4963 // -> search in all children
4964 MoveContextNodeToChildren;
4965
4966 ctnTypeDefinition, ctnVarDefinition, ctnConstDefinition,
4967 ctnGlobalProperty:
4968 if SearchInTypeVarConstGlobPropDefinition then exit;
4969
4970 ctnGenericType:
4971 if SearchInGenericType then exit;
4972 // ctnGenericParams: skip here, it was searched before searching the ancestors
4973
4974 ctnIdentifier:
4975 if (ContextNode.Parent.Desc in [ctnConstDefinition,ctnVarDefinition])
4976 and (ContextNode=ContextNode.Parent.LastChild)
4977 and SearchInTypeOfVarConst then exit;
4978
4979 ctnEnumIdentifier,ctnLabel:
4980 if SearchInEnumLabelDefinition then exit;
4981
4982 ctnProcedure:
4983 begin
4984 IdentifierFoundResult:=
4985 FindIdentifierInProcContext(ContextNode,Params);
4986 if IdentifierFoundResult in [ifrAbortSearch,ifrSuccess] then begin
4987 if CheckResult(IdentifierFoundResult=ifrSuccess,true) then begin
4988 {$IFDEF ShowProcSearch}
4989 DebugLn(['TFindDeclarationTool.FindIdentifierInContext ctnProcedure FOUND, stopping']);
4990 {$ENDIF}
4991 exit;
4992 end;
4993 {$IFDEF ShowProcSearch}
4994 DebugLn(['TFindDeclarationTool.FindIdentifierInContext ctnProcedure FOUND, continue']);
4995 {$ENDIF}
4996 end;
4997 end;
4998
4999 ctnProcedureHead:
5000 begin
5001 BuildSubTreeForProcHead(ContextNode);
5002 if ContextNode.FirstChild<>nil then
5003 ContextNode:=ContextNode.FirstChild; // the ctnParameterList
5004 end;
5005
5006 ctnProperty:
5007 if SearchInProperty then exit;
5008
5009 ctnUsesSection:
5010 begin
5011 if FindIdentifierInUsesSection(ContextNode,Params,True)
5012 and CheckResult(true,false) then
5013 exit;
5014 end;
5015
5016 ctnWithVariable:
5017 begin
5018 if FindIdentifierInWithVarContext(ContextNode,Params)
5019 and CheckResult(true,false) then
5020 exit;
5021 end;
5022
5023 ctnOnBlock:
5024 if SearchInOnBlockDefinition then exit;
5025
5026 ctnPointerType,ctnClassOfType:
5027 begin
5028 // pointer and class-of can be forward definitions
5029 // -> search in both directions
5030 Params.ContextNode:=ContextNode.Parent;
5031 if CheckResult(FindForwardIdentifier(Params,IsForward),false) then
5032 exit;
5033 end;
5034
5035 ctnRecordCase:
5036 begin
5037 // search in variable and variants
5038 MoveContextNodeToChildren;
5039 end;
5040
5041 end;
5042 end else begin
5043 Exclude(Params.Flags,fdfIgnoreCurContextNode);
5044 Exclude(Flags,fdfIgnoreCurContextNode);
5045 {$IFDEF ShowTriedContexts}
5046 DebugLn('[TFindDeclarationTool.FindIdentifierInContext] IgnoreCurContext ');
5047 {$ENDIF}
5048 end;
5049 if LastContextNode=ContextNode then begin
5050 // no special context switch => search next node
5051 if not LeavingContextIsPermitted then break;
5052 if not SearchNextNode then exit;
5053 end;
5054 until ContextNode=nil;
5055
5056 if SearchInHelpersInTheEnd then
5057 begin
5058 if SearchInHelpers then Exit;
5059 end;
5060
5061 if LastSearchedNode=Tree.Root then begin
5062 if SearchDefault then exit;
5063 end;
5064
5065 {except
5066 // unexpected exception
5067 on E: Exception do begin
5068 DebugLn('*** Unexpected Exception during find declaration: ',
5069 E.ClassName,': ',E.Message);
5070 DebugLn(' MainFilename=',MainFilename);
5071 raise;
5072 end;
5073 end;}
5074 // if we are here, the identifier was not found and there was no error
5075 if (FirstSearchedNode<>nil) and (Params.FoundProc=nil)
5076 and ([fdfCollect,fdfExtractOperand]*Flags=[]) then begin
5077 // add result to cache
5078 Params.NewNode:=nil;
5079 Params.NewCodeTool:=nil;
5080 AddResultToNodeCaches(FirstSearchedNode,LastSearchedNode,
5081 fdfSearchForward in Flags,Params,SearchRangeFlags);
5082 end;
5083 CheckResult(false,false);
5084 end;
5085
FindEnumInContextnull5086 function TFindDeclarationTool.FindEnumInContext(
5087 Params: TFindDeclarationParams): boolean;
5088 { search all subnodes for ctnEnumIdentifier
5089
5090 Params:
5091 Identifier
5092 ContextNode // = DeepestNode at Cursor
5093
5094 Result:
5095 true, if enum found
5096 }
5097 var OldContextNode, CurContextNode: TCodeTreeNode;
5098 CollectResult: TIdentifierFoundResult;
5099 SearchEnumIdentifiers: Boolean;
5100 begin
5101 Result:=false;
5102 CurContextNode:=Params.ContextNode;
5103 if CurContextNode=nil then exit;
5104 if CurContextNode.Desc=ctnEnumerationType then
5105 SearchEnumIdentifiers := not (Scanner.GetDirectiveValueAt(sdScopedEnums, CurContextNode.StartPos) = '1')
5106 else
5107 SearchEnumIdentifiers := False;
5108 CurContextNode:=CurContextNode.FirstChild;
5109 while CurContextNode<>nil do begin
5110 if SearchEnumIdentifiers and (CurContextNode.Desc=ctnEnumIdentifier) then begin
5111 if (fdfCollect in Params.Flags) then begin
5112 //debugln('TFindDeclarationTool.FindEnumInContext ',GetIdentifier(@Src[CurContextNode.StartPos]));
5113 CollectResult:=DoOnIdentifierFound(Params,CurContextNode);
5114 if CollectResult=ifrAbortSearch then begin
5115 Result:=false;
5116 exit;
5117 end else if CollectResult=ifrSuccess then begin
5118 Result:=true;
5119 Params.SetResult(Self,CurContextNode);
5120 exit;
5121 end;
5122 end else if CompareSrcIdentifiers(CurContextNode.StartPos,Params.Identifier)
5123 then begin
5124 // identifier found
5125 Result:=true;
5126 Params.SetResult(Self,CurContextNode);
5127 exit;
5128 end;
5129 end;
5130 if CurContextNode.FirstChild<>nil then begin
5131 OldContextNode:=Params.ContextNode;
5132 Params.ContextNode:=CurContextNode;
5133 Result:=FindEnumInContext(Params);
5134 Params.ContextNode:=OldContextNode;
5135 if Result then exit;
5136 end;
5137 CurContextNode:=CurContextNode.NextBrother;
5138 end;
5139 end;
5140
FindContextNodeAtCursornull5141 function TFindDeclarationTool.FindContextNodeAtCursor(
5142 Params: TFindDeclarationParams): TFindContext;
5143 { searches for the context node at a specific cursor pos
5144 Params.Context should contain the deepest node at cursor
5145 if there is no special context, then result is equal to Params.Context }
5146 var
5147 EndPos: integer;
5148 ExprType: TExpressionType;
5149 OldFlags: TFindDeclarationFlags;
5150 begin
5151 EndPos:=CurPos.StartPos;
5152 OldFlags:=Params.Flags;
5153 Params.Flags:=Params.Flags-[fdfFindVariable];
5154 ExprType:=FindExpressionTypeOfTerm(-1,EndPos,Params,false);
5155 Params.Flags:=OldFlags;
5156 if (ExprType.Desc=xtContext) then
5157 Result:=ExprType.Context
5158 else begin
5159 Result:=CleanFindContext;
5160 if fdfExceptionOnNotFound in Params.Flags then begin
5161 MoveCursorToCleanPos(EndPos);
5162 RaiseException(20170421200111,ctsNoContextNodeFoundAtCursor);
5163 end;
5164 end;
5165 end;
5166
FindBaseTypeOfNodenull5167 function TFindDeclarationTool.FindBaseTypeOfNode(
5168 Params: TFindDeclarationParams; Node: TCodeTreeNode; AliasType: PFindContext;
5169 NodeStack: PCodeTreeNodeStack): TFindContext;
5170 var
5171 MyNodeStack: TCodeTreeNodeStack;
5172
5173 procedure RaiseForwardClassNameLess;
5174 begin
5175 RaiseException(20170421200114,'[TFindDeclarationTool.FindBaseTypeOfNode] '
5176 +'forward class node without name');
5177 end;
5178
5179 procedure RaiseCircleDefs;
5180 begin
5181 Params.NewCodeTool.RaiseException(20170421200117,ctsCircleInDefinitions
5182 +' ('+ctsIdentifier+'='+GetIdentifier(Params.Identifier)+')');
5183 end;
5184
5185 procedure RaiseInternalError;
5186 begin
5187 Params.IdentifierTool.RaiseException(20170421200121,
5188 '[TFindDeclarationTool.FindBaseTypeOfNode]'
5189 +' internal error: not IsPCharInSrc(Params.Identifier) '
5190 +' Params.IdentifierTool.='
5191 +TCodeBuffer(Params.IdentifierTool.Scanner.MainCode).Filename
5192 +' Ident="'+GetIdentifier(Params.Identifier)+'"');
5193 end;
5194
5195 procedure RaiseBaseTypeOfNotFound;
5196 begin
5197 RaiseExceptionFmt(20170421200124,ctsBaseTypeOfNotFound,[GetIdentifier(Params.Identifier)]);
5198 end;
5199
5200 procedure RaiseClassOfWithoutIdentifier;
5201 begin
5202 RaiseExceptionFmt(20170421200133,ctsBaseTypeOfNotFound+' ("class of")',
5203 [GetIdentifier(Params.Identifier)]);
5204 end;
5205
5206 procedure RaiseForwardNotResolved(ClassIdentNode: TCodeTreeNode);
5207 begin
5208 RaiseExceptionFmt(20170421200136,ctsForwardClassDefinitionNotResolved,
5209 [copy(Src,ClassIdentNode.StartPos,
5210 ClassIdentNode.EndPos-ClassIdentNode.StartPos)]);
5211 end;
5212
5213 procedure RaiseClassOfNotResolved(ClassIdentNode: TCodeTreeNode);
5214 begin
5215 MoveCursorToNodeStart(ClassIdentNode);
5216 RaiseExceptionFmt(20170421200141,ctsClassOfDefinitionNotResolved,
5217 [copy(Src,ClassIdentNode.StartPos,
5218 ClassIdentNode.EndPos-ClassIdentNode.StartPos)]);
5219 end;
5220
5221 procedure SearchIdentifier(StartNode: TCodeTreeNode; CleanPos: integer;
5222 out IsPredefined: boolean; var Context: TFindContext);
5223 var
5224 TypeFound: Boolean;
5225 TestContext: TFindContext;
5226 IdentStart: LongInt;
5227 SubParams: TFindDeclarationParams;
5228 ExprType: TExpressionType;
5229 begin
5230 IsPredefined:=false;
5231
5232 SubParams:=TFindDeclarationParams.Create(Params);
5233 try
5234 SubParams.GenParams := Params.GenParams;
5235 IdentStart:=CleanPos;
5236 {$IFDEF ShowTriedBaseContexts}
5237 debugln(['TFindDeclarationTool.FindBaseTypeOfNode.SearchIdentifier Identifier=',GetIdentifier(@Src[IdentStart])]);
5238 {$ENDIF}
5239 SubParams.Flags:=[fdfSearchInParentNodes,fdfExceptionOnNotFound]
5240 +(fdfGlobals*SubParams.Flags);
5241 SubParams.ContextNode:=StartNode.Parent;
5242 if (SubParams.ContextNode.Desc in (AllIdentifierDefinitions))
5243 then begin
5244 // pascal allows things like 'var a: a;' -> skip var definition
5245 Include(SubParams.Flags,fdfIgnoreCurContextNode);
5246 end;
5247 if SubParams.ContextNode.Desc=ctnParameterList then
5248 // skip search in parameter list
5249 SubParams.ContextNode:=SubParams.ContextNode.Parent;
5250 if SubParams.ContextNode.Desc=ctnProcedureHead then
5251 // skip search in proc parameters
5252 SubParams.ContextNode:=SubParams.ContextNode.Parent;
5253
5254 MoveCursorToCleanPos(CleanPos);
5255 ReadNextAtom;
5256 ReadNextAtom;
5257 if (CurPos.Flag=cafPoint) or AtomIsChar('<') then begin
5258 // this is an expression, e.g. A.B or A<B>
5259 Include(SubParams.Flags,fdfFindVariable);
5260 ExprType:=FindExpressionTypeOfTerm(CleanPos,-1,SubParams,false);
5261 if ExprType.Desc=xtContext then begin
5262 if not (ExprType.Context.Node.Desc in [ctnTypeDefinition,ctnGenericType,ctnGenericParameter]) then
5263 begin
5264 // not a type
5265 {$IFDEF ShowTriedBaseContexts}
5266 debugln(['TFindDeclarationTool.FindBaseTypeOfNode.SearchIdentifier expression: type expected but found ',ExprTypeToString(ExprType)]);
5267 {$ENDIF}
5268 MoveCursorToCleanPos(IdentStart);
5269 ReadNextAtom;
5270 RaiseExceptionFmt(20170421200144,ctsStrExpectedButAtomFound,
5271 [ctsTypeIdentifier,GetAtom]);
5272 end;
5273 Context:=ExprType.Context;
5274 end else begin
5275 IsPredefined:=true;
5276 end;
5277 exit;
5278 end;
5279
5280 SubParams.SetIdentifier(Self,@Src[IdentStart],nil);
5281 TypeFound:=FindIdentifierInContext(SubParams);
5282 if TypeFound and (SubParams.NewNode.Desc in [ctnUnit,ctnLibrary,ctnPackage])
5283 then begin
5284 // identifier is a unit
5285 // => type expected
5286 MoveCursorToCleanPos(IdentStart);
5287 ReadNextAtom; // read AUnitName
5288 SaveRaiseCharExpectedButAtomFound(20170421200146,'.');
5289 end;
5290 if TypeFound and (SubParams.NewNode.Desc=ctnGenericParameter) then begin
5291 TypeFound:=SubParams.FindGenericParamType;
5292 end;
5293 if TypeFound then begin
5294 // only types allowed here
5295 TestContext.Tool:=SubParams.NewCodeTool;
5296 TestContext.Node:=SubParams.NewNode;
5297 if not (TestContext.Node.Desc in [ctnTypeDefinition,ctnGenericType,ctnGenericParameter]) then
5298 begin
5299 // not a type
5300 {$IFDEF ShowTriedBaseContexts}
5301 debugln(['TFindDeclarationTool.FindBaseTypeOfNode.SearchIdentifier expected type but found ',TestContext.Node.DescAsString]);
5302 {$ENDIF}
5303 MoveCursorToCleanPos(IdentStart);
5304 ReadNextAtom;
5305 RaiseExceptionFmt(20170421200149,ctsStrExpectedButAtomFound,
5306 [ctsTypeIdentifier,GetAtom]);
5307 end;
5308 Context:=TestContext;
5309 {$IFDEF ShowTriedBaseContexts}
5310 debugln(['TFindDeclarationTool.FindBaseTypeOfNode.SearchIdentifier found ',GetIdentifier(@Src[IdentStart]),' Node=',Context.Node.DescAsString,' ',Context.Tool.CleanPosToStr(Context.Node.StartPos,true)]);
5311 {$ENDIF}
5312 end else begin
5313 // predefined identifier
5314 IsPredefined:=true;
5315 end;
5316
5317 finally
5318 SubParams.Free;
5319 end;
5320 end;
5321
5322 procedure CheckResult(var Context: TFindContext);
5323 var
5324 ResultNode: TCodeTreeNode;
5325 OldFlags: TFindDeclarationFlags;
5326 AliasContext: TFindContext;
5327 Cache: TBaseTypeCache;
5328 begin
5329 if (NodeStack<>nil) and (NodeStack<>@MyNodeStack) then exit; // will be handled by caller
5330
5331 if (Context.Node<>nil) and (Context.Node.Desc in [ctnProcedure,ctnProcedureHead])
5332 and (fdfFunctionResult in Params.Flags) then begin
5333 // Note: do not resolve a constructor here
5334 // because TMyClass.Create should return TMyClass
5335 // and not TObject, where the Create is defined
5336 // a proc -> if this is a function then return the Context type
Contextnull5337 //debugln(['TFindDeclarationTool.FindBaseTypeOfNode checking function Context: ',Context.Tool.ExtractNode(Context.Node,[])]);
5338 Context.Tool.BuildSubTreeForProcHead(Context.Node,ResultNode);
5339 if (ResultNode<>nil) then begin
5340 // a function or an overloaded operator
5341 // search further for the base type of the function Context type
5342 OldFlags:=Params.Flags;
5343 Exclude(Params.Flags,fdfFunctionResult);
5344 //debugln(['TFindDeclarationTool.FindBaseTypeOfNode searching for function Context type: ',Context.Tool.ExtractNode(DummyNode,[])]);
5345 Context:=Context.Tool.FindBaseTypeOfNode(Params,ResultNode,AliasType);
5346 AliasType:=nil; // aliasing has been done
5347 Params.Flags:=OldFlags;
5348 exit;
5349 end;
5350 end;
5351 if (Context.Node=nil) and (fdfExceptionOnNotFound in Params.Flags) then begin
5352 if (Context.Tool<>nil) and (Params.Identifier<>nil) then begin
5353
5354 // ToDo ppu, dcu
5355
5356 if (not Params.IdentifierTool.IsPCharInSrc(Params.Identifier)) then
5357 RaiseInternalError;
5358 Params.IdentifierTool.MoveCursorToCleanPos(Params.Identifier);
5359 end;
5360 RaiseBaseTypeOfNotFound;
5361 end;
5362 if AliasType<>nil then begin
5363 // follow the base type chain to the first type
5364 // for example: var d: TDateTime; use TDateTime, instead of Double.
5365 AliasContext.Node:=Node;
5366 AliasContext.Tool:=Self;
5367 while AliasContext.Node<>nil do begin
5368 if AliasContext.Node.Desc in [ctnTypeDefinition,ctnGenericType] then begin
5369 {$IF defined(ShowExprEval) or defined(ShowTriedBaseContexts)}
5370 debugln(['TFindDeclarationTool.FindBaseTypeOfNode.CheckResult using alias ',AliasContext.Tool.ExtractDefinitionName(AliasContext.Node),' instead of base type ',Context.Node.DescAsString]);
5371 {$ENDIF}
5372 AliasType^:=AliasContext;
5373 exit;
5374 end;
5375 if AliasContext.Node.Cache is TBaseTypeCache then begin
5376 Cache:=TBaseTypeCache(AliasContext.Node.Cache);
5377 if AliasContext.Node=Cache.NextNode then break;
5378 AliasContext.Node:=Cache.NextNode;
5379 AliasContext.Tool:=TFindDeclarationTool(Cache.NextTool);
5380 end else
5381 break;
5382 end;
5383 end;
5384 end;
5385
5386 var
5387 OldInput: TFindDeclarationInput;
5388 ClassIdentNode: TCodeTreeNode;
5389 TestContext: TFindContext;
5390 OldPos: integer;
5391 SpecializeNode: TCodeTreeNode;
5392 NameNode: TCodeTreeNode;
5393 IsPredefined: boolean;
5394 OldStartFlags: TFindDeclarationFlags;
5395 begin
5396 {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF}
5397 //debugln(['TFindDeclarationTool.FindBaseTypeOfNode Flags=[',dbgs(Params.Flags),'] CacheValid=',Node.Cache is TBaseTypeCache]);
5398 if (Node<>nil) and (Node.Cache is TBaseTypeCache) then begin
5399 // base type already cached
5400 Result:=CreateFindContext(TBaseTypeCache(Node.Cache));
5401 CheckResult(Result);
5402 exit;
5403 end;
5404
5405 Result.Node:=Node;
5406 Result.Tool:=Self;
5407 OldStartFlags:=Params.Flags;
5408 Exclude(Params.Flags,fdfTopLvlResolving);
5409 if NodeStack=nil then begin
5410 NodeStack:=@MyNodeStack;
5411 InitializeNodeStack(NodeStack);
5412 end;
5413 try
5414 while (Result.Node<>nil) do begin
5415 if (Result.Node.Cache is TBaseTypeCache) then begin
5416 // base type already cached
5417 if NodeStack^.StackPtr>=0 then
5418 AddNodeToStack(NodeStack,Result.Tool,Result.Node);
5419 Result:=CreateFindContext(TBaseTypeCache(Result.Node.Cache));
5420 break;
5421 end;
5422 {$IFDEF ShowTriedBaseContexts}
5423 DebugLn('[TFindDeclarationTool.FindBaseTypeOfNode] LOOP Result=',Result.Node.DescAsString,' ',Result.Tool.CleanPosToStr(Result.Node.StartPos,true),' Flags=[',dbgs(Params.Flags),']');
5424 {$ENDIF}
5425 if NodeExistsInStack(NodeStack,Result.Node) then begin
5426 // cycle detected
5427 Result.Tool.MoveCursorToNodeStart(Result.Node);
5428 Result.Tool.RaiseException(20170421200151,ctsCircleInDefinitions);
5429 end;
5430 {$IFDEF CheckNodeTool}Result.Tool.CheckNodeTool(Result.Node);{$ENDIF}
5431
5432 if Result.Tool<>Self then begin
5433 {$IFDEF ShowTriedBaseContexts}
5434 DebugLn(['[TFindDeclarationTool.FindBaseTypeOfNode] continuing in ',Result.Tool.MainFilename]);
5435 {$ENDIF}
5436 Result:=Result.Tool.FindBaseTypeOfNode(Params,Result.Node,AliasType,NodeStack);
5437 break;
5438 end;
5439
5440 AddNodeToStack(NodeStack,Result.Tool,Result.Node);
5441
5442 if (Result.Node.Desc in (AllSimpleIdentifierDefinitions+[ctnGenericType]))
5443 then begin
5444 // instead of variable/const/type definition, return the type
5445 TestContext.Node:=FindTypeNodeOfDefinition(Result.Node);
5446 if TestContext.Node=nil then
5447 // some constants and variants do not have a type
5448 break;
5449 Result.Node:=TestContext.Node;
5450 end else
5451 if (Result.Node.Desc in AllClasses)
5452 and ((Result.Node.SubDesc and ctnsForwardDeclaration)>0) then
5453 begin
5454 // this is a forward defined class
5455 // -> search the real class
5456 {$IFDEF ShowTriedBaseContexts}
5457 DebugLn('[TFindDeclarationTool.FindBaseTypeOfNode] Class is forward');
5458 {$ENDIF}
5459
5460 // ToDo: check for cycles in ancestor chain
5461
5462 ClassIdentNode:=Result.Node.Parent;
5463 if (ClassIdentNode=nil)
5464 or (not (ClassIdentNode.Desc in [ctnTypeDefinition,ctnGenericType]))
5465 then begin
5466 MoveCursorToCleanPos(Result.Node.StartPos);
5467 RaiseForwardClassNameLess;
5468 end;
5469 Params.Save(OldInput);
5470 Params.SetIdentifier(Self,@Src[ClassIdentNode.StartPos],
5471 @CheckSrcIdentifier);
5472 Params.Flags:=[fdfSearchInParentNodes,fdfSearchForward,
5473 fdfIgnoreUsedUnits,fdfExceptionOnNotFound,
5474 fdfIgnoreCurContextNode]
5475 +(fdfGlobals*Params.Flags);
5476 Params.ContextNode:=ClassIdentNode;
5477 FindIdentifierInContext(Params);
5478 if (not (Params.NewNode.Desc in [ctnTypeDefinition,ctnGenericType]))
5479 or (Params.NewCodeTool<>Self) then begin
5480 MoveCursorToCleanPos(Result.Node.StartPos);
5481 RaiseForwardNotResolved(ClassIdentNode);
5482 end;
5483 Result.Tool:=Params.NewCodeTool;
5484 Result.Node:=Params.NewNode;
5485 Params.Load(OldInput,true);
5486 end else
5487 if (Result.Node.Desc=ctnClassOfType) and (fdfFindChildren in Params.Flags)
5488 then begin
5489 // this is a 'class of' type
5490 // -> search the real class
5491 {$IFDEF ShowTriedBaseContexts}
5492 DebugLn('[TFindDeclarationTool.FindBaseTypeOfNode] "Class Of"');
5493 {$ENDIF}
5494
5495 // ToDo: check for cycles in ancestor chain
5496
5497 ClassIdentNode:=Result.Node.FirstChild;
5498 if (ClassIdentNode=nil) or (not (ClassIdentNode.Desc=ctnIdentifier))
5499 then begin
5500 MoveCursorToCleanPos(Result.Node.StartPos);
5501 RaiseClassOfWithoutIdentifier;
5502 end;
5503 Params.Save(OldInput);
5504 // first search backwards
5505 Params.SetIdentifier(Self,@Src[ClassIdentNode.StartPos],
5506 @CheckSrcIdentifier);
5507 Params.Flags:=[fdfSearchInParentNodes,
5508 fdfIgnoreCurContextNode]
5509 +(fdfGlobals*Params.Flags)-[fdfExceptionOnNotFound];
5510 Params.ContextNode:=Result.Node.Parent;
5511 if not FindIdentifierInContext(Params) then begin
5512 // then search forwards
5513 Params.Load(OldInput,false);
5514 Params.SetIdentifier(Self,@Src[ClassIdentNode.StartPos],
5515 @CheckSrcIdentifier);
5516 Params.Flags:=[fdfSearchInParentNodes,fdfExceptionOnNotFound,
5517 fdfIgnoreCurContextNode,fdfSearchForward]
5518 +(fdfGlobals*Params.Flags);
5519 Params.ContextNode:=Result.Node.Parent;
5520 FindIdentifierInContext(Params);
5521 end;
5522 if not (Params.NewNode.Desc in [ctnTypeDefinition,ctnGenericType]) then
5523 begin
5524 MoveCursorToCleanPos(Result.Node.StartPos);
5525 RaiseClassOfNotResolved(ClassIdentNode);
5526 end;
5527 Result.Tool:=Params.NewCodeTool;
5528 Result.Node:=Params.NewNode;
5529 Params.Load(OldInput,true);
5530 end else
5531 if (Result.Node.Desc=ctnOnIdentifier) and (Result.Node.PriorBrother=nil)
5532 then begin
5533 // this is the ON variable node, the type comes right behind
5534 Result.Node:=Result.Node.NextBrother;
5535 end else if Result.Node.Desc=ctnSrcName then begin
5536 break;
5537 end else if (Result.Node.Desc=ctnIdentifier)
5538 and (Result.Node.Parent.Desc=ctnSrcName) then begin
5539 if (Result.Node.NextBrother=nil) then
5540 Result.Node:=Result.Node.Parent;
5541 break;
5542 end else
5543 if (Result.Node.Desc in [ctnIdentifier,ctnOnIdentifier])
5544 then begin
5545 // this type is just an alias for another type
5546 // -> search the basic type
5547 if Result.Node.Parent=nil then
5548 break;
5549 SearchIdentifier(Result.Node,Result.Node.StartPos,IsPredefined,Result);
5550 if IsPredefined then break;
5551 end else
5552 if (Result.Node.Desc=ctnProperty)
5553 or (Result.Node.Desc=ctnGlobalProperty) then begin
5554 // this is a property -> search the type definition of the property
5555 if MoveCursorToPropType(Result.Node) then begin
5556 // property has a type
5557 SearchIdentifier(Result.Node,CurPos.StartPos,IsPredefined,Result);
5558 if IsPredefined then break;
5559 end else if (Result.Node.Desc=ctnProperty) then begin
5560 // property has no type
5561 // -> search ancestor property
5562 Params.Save(OldInput);
5563 if not MoveCursorToPropName(Result.Node) then break;
5564 OldPos:=CurPos.StartPos;
5565 Params.SetIdentifier(Self,@Src[CurPos.StartPos],nil);
5566 Params.Flags:=[fdfExceptionOnNotFound,fdfSearchInAncestors,fdfSearchInHelpers]
5567 +(fdfGlobalsSameIdent*Params.Flags);
5568 FindIdentifierInAncestors(Result.Node.Parent.Parent,Params);
5569 TestContext.Tool:=Params.NewCodeTool;
5570 TestContext.Node:=Params.NewNode;
5571 Params.Load(OldInput,true);
5572 if Params.NewNode.Desc<>ctnProperty then begin
5573 // ancestor is not a property
5574 MoveCursorToCleanPos(OldPos);
5575 RaiseException(20170421200153,ctsAncestorIsNotProperty);
5576 end;
5577 Result:=TestContext;
5578 end else
5579 break;
5580 end else
5581 if Result.Node.Desc=ctnProcedure then begin
5582 Result.Node:=Result.Node.FirstChild;
5583 break;
5584 end else
5585 if Result.Node.Desc=ctnProcedureHead then begin
5586 break;
5587 end else
5588 if (Result.Node.Desc=ctnTypeType) then begin
5589 if fdfTypeType in Params.Flags then
5590 break; // the type node is wanted, not its real type
5591 // a TypeType is for example 'MyInt = type integer;'
5592 // the context is not the 'type' keyword, but the identifier after it.
5593 Result.Node:=Result.Node.FirstChild;
5594 end else
5595 if (Result.Node.Desc=ctnEnumIdentifier) then begin
5596 // an enum identifier
5597 if fdfEnumIdentifier in Params.Flags then
5598 break; // the enum is wanted, not its type
5599 // an enum identifier, the base type is the enumeration
5600 Result.Node:=Result.Node.Parent;
5601 end else
5602 if (Result.Node.Desc=ctnSpecialize) then begin
5603 // go to the type name of the specialisation
5604 SpecializeNode:=Result.Node;
5605 NameNode:=SpecializeNode.FirstChild;
5606 Result.Node:=NameNode;
5607 if Result.Node=nil then break;
5608 Params.SetGenericParamValues(Self, SpecializeNode);
5609 Params.UpdateGenericParamMapping(Self, SpecializeNode.FirstChild.NextBrother, Nil);
5610 SearchIdentifier(SpecializeNode,NameNode.StartPos,IsPredefined,Result);
5611 if (Result.Node=nil) or (Result.Node.Desc<>ctnGenericType) then begin
5612 // not a generic
5613 MoveCursorToNodeStart(NameNode);
5614 ReadNextAtom;
5615 RaiseExceptionFmt(20170421200156,ctsStrExpectedButAtomFound,
5616 [ctsGenericIdentifier,GetAtom]);
5617 end;
5618 end else
5619 break;
5620 end;
5621
5622 Params.Flags:=OldStartFlags;
5623 finally
5624 if NodeStack=@MyNodeStack then begin
5625 // cache the result in all nodes
5626 // do not cache the result of generic type
5627 if not Assigned(Params.GenParams.ParamValuesTool) then
5628 CreateBaseTypeCaches(NodeStack,Result);
5629 // free node stack
5630 FinalizeNodeStack(NodeStack);
5631 end;
5632 end;
5633
5634 CheckResult(Result);
5635
5636 {$IFDEF ShowFoundIdentifier}
5637 Debugln(['[TFindDeclarationTool.FindBaseTypeOfNode] END Node=',Node.DescAsString,' Result=',Result.Node.DescAsString]);
5638 {$ENDIF}
5639 end;
5640
FindIdentifierInBasicTypeHelpersnull5641 function TFindDeclarationTool.FindIdentifierInBasicTypeHelpers(
5642 ExprType: TExpressionTypeDesc; Params: TFindDeclarationParams): Boolean;
5643 var
5644 OldFlags: TFindDeclarationFlags;
5645 FullExprType: TExpressionType;
5646 CHContext: TFindContext;
5647 Helpers: TFDHelpersList;
5648 begin
5649 Helpers:=Params.GetHelpers(fdhlkDelphiHelper);
5650 if Helpers=nil then exit(false);
5651 FullExprType := CleanExpressionType;
5652 FullExprType.Desc := ExprType;
5653 case FullExprType.Desc of
5654 xtConstString: FullExprType.Desc:=GetDefaultStringType;
5655 xtConstOrdInteger: FullExprType.Desc:=xtLongint;
5656 xtConstBoolean: FullExprType.Desc:=xtBoolean;
5657 xtConstReal: FullExprType.Desc:=xtDouble;
5658 end;
5659 //debugln(['TFindDeclarationTool.FindIdentifierInBasicTypeHelpers ',ExprTypeToString(FullExprType)]);
5660
5661 // find class helper functions
5662 CHContext := Helpers.FindFromExprType(FullExprType);
5663
5664 if Assigned(CHContext.Node) and Assigned(CHContext.Tool) then
5665 begin
5666 OldFlags := Params.Flags;
5667 try
5668 Exclude(Params.Flags, fdfExceptionOnNotFound);
5669 Exclude(Params.Flags, fdfIgnoreCurContextNode);
5670 Include(Params.Flags, fdfIgnoreUsedUnits);
5671 Params.ContextNode := CHContext.Node;
5672
5673 Result := CHContext.Tool.FindIdentifierInContext(Params);
5674 finally
5675 Params.Flags := OldFlags;
5676 end;
5677 end else
5678 Result := False;
5679 end;
5680
FindDeclarationAndOverloadnull5681 function TFindDeclarationTool.FindDeclarationAndOverload(
5682 const CursorPos: TCodeXYPosition; out ListOfPCodeXYPosition: TFPList;
5683 Flags: TFindDeclarationListFlags): boolean;
5684 var
5685 CurCursorPos: TCodeXYPosition;
5686 NewTool: TFindDeclarationTool;
5687 NewNode: TCodeTreeNode;
5688 NewPos: TCodeXYPosition;
5689 NewTopLine: integer;
5690 CurTool: TFindDeclarationTool;
5691 OldPositions: TFPList;
5692 NodeList: TFPList;
5693 CleanPos: integer;
5694 AtDefinition: Boolean;
5695
5696 procedure AddPos;
5697 begin
5698 AddCodePosition(OldPositions,NewPos);
5699 if (NodeList.IndexOf(NewNode)>=0) then begin
5700 {$IFDEF VerboseFindDeclarationAndOverload}
5701 debugln(['AddPos skip, because Node already in NodList']);
5702 {$ENDIF}
5703 exit;
5704 end;
5705
5706 if (fdlfOneOverloadPerUnit in Flags)
5707 and (NodeList.Count>0)
5708 and (TCodeTreeNode(NodeList[NodeList.Count-1]).GetRoot=NewTool.Tree.Root)
5709 then begin
5710 {$IFDEF VerboseFindDeclarationAndOverload}
5711 debugln(['AddPos skip, because in same unit']);
5712 {$ENDIF}
5713 exit;
5714 end;
5715 NodeList.Add(NewNode);
5716
5717 if (fdlfWithoutEmptyProperties in Flags)
5718 and (NewNode.Desc=ctnProperty)
5719 and (NewTool.PropNodeIsTypeLess(NewNode)) then begin
5720 {$IFDEF VerboseFindDeclarationAndOverload}
5721 debugln(['AddPos skip, because property has no type']);
5722 {$ENDIF}
5723 exit;
5724 end;
5725 if (fdlfWithoutForwards in Flags) then begin
5726 if (NewNode.Desc in [ctnTypeDefinition,ctnGenericType])
5727 and NewTool.NodeIsForwardDeclaration(NewNode) then begin
5728 {$IFDEF VerboseFindDeclarationAndOverload}
5729 debugln(['AddPos skip, because type is forward']);
5730 {$ENDIF}
5731 exit;
5732 end;
5733 if (NewNode.Desc=ctnProcedure)
5734 and ((NewNode.SubDesc and ctnsForwardDeclaration)>0)
5735 and (not NewNode.HasParentOfType(ctnInterface)) then begin
5736 {$IFDEF VerboseFindDeclarationAndOverload}
5737 debugln(['AddPos skip, because proc is forward']);
5738 {$ENDIF}
5739 exit;
5740 end;
5741 end;
5742
5743 AddCodePosition(ListOfPCodeXYPosition,NewPos);
5744 end;
5745
5746 function StartPositionAtDefinition: boolean;
5747 begin
5748 if (NewNode.Desc in AllIdentifierDefinitions)
5749 and (PositionInDefinitionName(NewNode,CleanPos)) then
5750 Result:=true
5751 else if (NewNode.Desc in [ctnProcedure,ctnProcedureHead])
5752 and (PositionInProcName(NewNode,false,CleanPos)) then
5753 Result:=true
5754 else if (NewNode.Desc in [ctnProperty,ctnGlobalProperty])
5755 and (PositionInPropertyName(NewNode,CleanPos)) then
5756 Result:=true
5757 else if (NewNode.Desc in AllSourceTypes)
5758 and (PositionInSourceName(CleanPos)) then
5759 Result:=true
5760 else
5761 Result:=false;
5762 end;
5763
5764 function StartPositionAtFunctionResult: boolean;
5765 var
5766 Node: TCodeTreeNode;
5767 begin
5768 Result:=false;
5769 if (NewNode.Desc in [ctnProcedureHead,ctnIdentifier])
5770 and PositionInFuncResultName(NewNode,CleanPos) then begin
5771 Node:=NewNode;
5772 if Node.Desc=ctnProcedureHead then begin
5773 Node:=Node.FirstChild;
5774 if Node=nil then exit;
5775 if Node.Desc=ctnParameterList then Node:=Node.NextBrother;
5776 if Node=nil then exit;
5777 end;
5778 if Node.Desc in [ctnVarDefinition,ctnIdentifier] then begin
5779 // return the function result type or the operator variable name
5780 NewNode:=Node;
5781 Result:=true;
5782 end;
5783 end;
5784 end;
5785
5786 begin
5787 {$IFDEF VerboseFindDeclarationAndOverload}
5788 debugln(['TFindDeclarationTool.FindDeclarationAndOverload START']);
5789 {$ENDIF}
5790 Result:=true;
5791 ListOfPCodeXYPosition:=nil;
5792 NewTool:=nil;
5793 NewNode:=nil;
5794 OldPositions:=nil;
5795 NodeList:=nil;
5796
5797 ActivateGlobalWriteLock;
5798 try
5799 BuildTreeAndGetCleanPos(trTillCursorSection,lsrEnd,CursorPos,CleanPos,[]);
5800
5801 NodeList:=TFPList.Create;
5802 NewTool:=Self;
5803 NewNode:=BuildSubTreeAndFindDeepestNodeAtPos(CleanPos,true);
5804 NewPos:=CursorPos;
5805 AtDefinition:=StartPositionAtDefinition;
5806 if AtDefinition then begin
5807 AddPos;
5808 if fdlfIfStartIsDefinitionStop in Flags then begin
5809 {$IFDEF VerboseFindDeclarationAndOverload}
5810 debugln(['TFindDeclarationTool.FindDeclarationAndOverload AtDefiniton and fdlfIfStartIsDefinitionStop in Flags']);
5811 {$ENDIF}
5812 exit;
5813 end;
5814 end;
5815 if StartPositionAtFunctionResult then begin
5816 AddPos;
5817 // the function result has no overloads => stop search
5818 {$IFDEF VerboseFindDeclarationAndOverload}
resultnull5819 debugln(['TFindDeclarationTool.FindDeclarationAndOverload function result has no overloads']);
5820 {$ENDIF}
5821 exit;
5822 end;
5823 if NewNode.Desc in AllSourceTypes then begin
5824 // the unit name has no overloads => stop search
5825 {$IFDEF VerboseFindDeclarationAndOverload}
5826 debugln(['TFindDeclarationTool.FindDeclarationAndOverload unit name has no overload']);
5827 {$ENDIF}
5828 exit;
5829 end;
5830
5831 CurCursorPos:=CursorPos;
5832 CurTool:=Self;
5833 try
5834 while CurTool.FindDeclaration(CurCursorPos,DefaultFindSmartFlags
5835 +[fsfSearchSourceName],
5836 NewTool,NewNode,NewPos,NewTopLine) do
5837 begin
5838 if IndexOfCodePosition(OldPositions,@NewPos)>=0 then break;
5839 AddPos;
5840 CurCursorPos:=NewPos;
5841 CurTool:=NewTool;
5842 {$IFDEF VerboseFindDeclarationAndOverload}
5843 debugln('TFindDeclarationTool.FindDeclarationAndOverload Self="',MainFilename,'" ');
5844 if CurCursorPos.Code<>nil then
5845 debugln(' CurCursorPos=',CurCursorPos.Code.Filename,' ',dbgs(CurCursorPos.X),',',dbgs(CurCursorPos.Y));
5846 if CurTool<>nil then
5847 debugln(' CurTool=',CurTool.MainFilename);
5848 {$ENDIF}
5849 if (CurTool=nil) then exit;
5850 end;
5851 except
5852 // ignore normal errors
5853 on E: ECodeToolError do ;
5854 on E: ELinkScannerError do ;
5855 end;
5856 finally
5857 FreeListOfPCodeXYPosition(OldPositions);
5858 NodeList.Free;
5859 DeactivateGlobalWriteLock;
5860 end;
5861 end;
5862
FindIdentifierContextsAtStatementnull5863 function TFindDeclarationTool.FindIdentifierContextsAtStatement(CleanPos: integer;
5864 out IsSubIdentifier: boolean; out ListOfPFindContext: TFPList): boolean;
5865 var
5866 Params: TFindDeclarationParams;
5867 CursorNode: TCodeTreeNode;
5868 Node: TCodeTreeNode;
5869 Context: TFindContext;
5870 WithNode: TCodeTreeNode;
5871 ExprType: TExpressionType;
5872 begin
5873 Result:=false;
5874 IsSubIdentifier:=false;
5875 ListOfPFindContext:=nil;
5876 CursorNode:=FindDeepestNodeAtPos(CleanPos,true);
5877 if not (CursorNode.Desc in AllPascalStatements) then begin
5878 debugln(['TFindDeclarationTool.FindIdentifierContextsAtStatement CursorNode.Desc=',CursorNode.DescAsString]);
5879 exit;
5880 end;
5881 // check expression in front
5882 MoveCursorToCleanPos(CleanPos);
5883 ReadPriorAtom;
5884 if CurPos.Flag=cafPoint then begin
5885 // sub identifier
5886 // for example A.Identifier
5887 IsSubIdentifier:=true;
5888 // search the context of A and add it to the ListOfPFindContext
5889 Params:=TFindDeclarationParams.Create(Self, CursorNode);
5890 try
5891 Params.ContextNode:=CursorNode;
5892 Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors,fdfSearchInHelpers,
5893 fdfTopLvlResolving,fdfFunctionResult];
5894 ExprType:=FindExpressionTypeOfTerm(-1,CleanPos,Params,false);
5895 finally
5896 Params.Free;
5897 end;
5898 if ExprType.Desc=xtContext then
5899 AddFindContext(ListOfPFindContext,ExprType.Context);
5900 end else begin
5901 // not a sub identifier
5902 BuildSubTree(CursorNode);
5903 CursorNode:=FindDeepestNodeAtPos(CursorNode,CleanPos,true);
5904 Node:=CursorNode;
5905 while Node<>nil do begin
5906 case Node.Desc of
5907 ctnWithStatement:
5908 begin
5909 // add all With contexts
5910 WithNode:=Node.Parent;
5911 while WithNode<>nil do begin
5912 if WithNode.Desc<>ctnWithVariable then break;
5913 Params:=TFindDeclarationParams.Create(Self, WithNode);
5914 try
5915 Params.ContextNode:=WithNode;
5916 Params.Flags:=[fdfExceptionOnNotFound,fdfSearchInAncestors,fdfSearchInHelpers,
5917 fdfSearchInParentNodes,fdfFunctionResult,fdfIgnoreCurContextNode,
5918 fdfFindChildren];
5919 ExprType:=FindExpressionResultType(Params,WithNode.StartPos,-1);
5920 if ExprType.Desc=xtContext then
5921 AddFindContext(ListOfPFindContext,ExprType.Context);
5922 finally
5923 Params.Free;
5924 end;
5925 WithNode:=WithNode.PriorBrother;
5926 end;
5927 end;
5928 ctnProcedure:
5929 begin
5930 // add procedure context
5931 Context.Node:=Node;
5932 Context.Tool:=Self;
5933 AddFindContext(ListOfPFindContext,Context);
5934 if NodeIsMethodBody(Node) then begin
5935 // add class context
5936 Context.Node:=FindClassNodeForMethodBody(Node,true,false);
5937 if Context.Node<>nil then begin
5938 Context.Tool:=Self;
5939 AddFindContext(ListOfPFindContext,Context);
5940 end;
5941 end;
5942 end;
5943 ctnImplementation:
5944 begin
5945 Context.Node:=Node;
5946 Context.Tool:=Self;
5947 AddFindContext(ListOfPFindContext,Context);
5948 end;
5949 end;
5950 Node:=Node.Parent;
5951 end;
5952 end;
5953 Result:=true;
5954 end;
5955
FindIdentifierInAncestorsnull5956 function TFindDeclarationTool.FindIdentifierInAncestors(
5957 ClassNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean;
5958 var
5959 IdentFoundResult: TIdentifierFoundResult;
5960 begin
5961 Result := FindIdentifierInAncestors(ClassNode, Params, IdentFoundResult{%H-});
5962 end;
5963
FindClassAndAncestorsnull5964 function TFindDeclarationTool.FindClassAndAncestors(ClassNode: TCodeTreeNode;
5965 var ListOfPFindContext: TFPList; ExceptionOnNotFound: boolean): boolean;
5966 var
5967 Params: TFindDeclarationParams;
5968
5969 function Search: boolean;
5970 var
5971 CurTool: TFindDeclarationTool;
5972 FoundContext: TFindContext;
5973 begin
5974 CurTool:=Self;
5975 while CurTool.FindAncestorOfClass(ClassNode,Params,true) do begin
5976 if (Params.NewCodeTool=nil) then break;
5977 FoundContext.Tool:=Params.NewCodeTool;
5978 FoundContext.Node:=Params.NewNode;
5979 if IndexOfFindContext(ListOfPFindContext,@FoundContext)>=0 then break;
5980 AddFindContext(ListOfPFindContext,FoundContext);
5981 //debugln('TFindDeclarationTool.FindClassAndAncestors FoundContext=',DbgsFC(FoundContext));
5982 CurTool:=Params.NewCodeTool;
5983 ClassNode:=Params.NewNode;
5984 if (ClassNode=nil)
5985 or (not (ClassNode.Desc in AllClasses)) then
5986 break;
5987 end;
5988 Result:=true;
5989 end;
5990
5991 begin
5992 {$IFDEF CheckNodeTool}CheckNodeTool(ClassNode);{$ENDIF}
5993 Result:=false;
5994 if (ClassNode=nil) or (not (ClassNode.Desc in AllClasses))
5995 or (ClassNode.Parent=nil)
5996 or (not (ClassNode.Parent.Desc in [ctnTypeDefinition,ctnGenericType])) then
5997 exit;
5998
5999 AddFindContext(ListOfPFindContext,CreateFindContext(Self,ClassNode));
6000
6001 Params:=TFindDeclarationParams.Create;
6002 ActivateGlobalWriteLock;
6003 try
6004 if ExceptionOnNotFound then
6005 Result:=Search
6006 else begin
6007 try
6008 Result:=Search;
6009 except
6010 // catch syntax errors
6011 on E: ECodeToolError do ;
6012 on E: ELinkScannerError do ;
6013 end;
6014 end;
6015 finally
6016 DeactivateGlobalWriteLock;
6017 Params.Free;
6018 end;
6019 end;
6020
6021 procedure TFindDeclarationTool.FindHelpersInContext(
6022 Params: TFindDeclarationParams);
6023 var
6024 Node: TCodeTreeNode;
6025 begin
6026 Node:=Params.StartNode;
6027 Params.FNeedHelpers:=false;
6028 while Node<>nil do
6029 begin
6030 case Node.Desc of
6031 ctnClassHelper, ctnRecordHelper, ctnTypeHelper:
6032 if (Node.Parent.Desc = ctnTypeDefinition) then
6033 Params.GetHelpers(fdhlkDelphiHelper,true).AddFromHelperNode(Node, Self,
6034 False{ keep last found Helper }
6035 );
6036 ctnObjCCategory:
6037 if (Node.Parent.Desc = ctnTypeDefinition) then
6038 Params.GetHelpers(fdhlkObjCCategory,true).AddFromHelperNode(Node, Self, False);
6039 ctnUsesSection:
6040 FindHelpersInUsesSection(Node, Params);
6041 end;
6042 Node := Node.Prior;
6043 end;
6044 end;
6045
6046 procedure TFindDeclarationTool.FindHelpersInInterface(
6047 AskingTool: TFindDeclarationTool; Params: TFindDeclarationParams);
6048 var
6049 HelperKind: TFDHelpersListKind;
6050 Cache: TFDHelpersList;
6051 begin
6052 // build tree for pascal source
6053 if not BuildInterfaceIdentifierCache(true) then exit;
6054 if (AskingTool<>Self) and (AskingTool<>nil) then
6055 begin
6056 AskingTool.AddToolDependency(Self);
6057 for HelperKind in TFDHelpersListKind do begin
6058 Cache:=FInterfaceHelperCache[HelperKind];
6059 if (Cache<>nil) and (Cache.Count>0) then
6060 Params.GetHelpers(HelperKind,true).AddFromList(FInterfaceHelperCache[HelperKind]);
6061 end;
6062 end;
6063 end;
6064
6065 procedure TFindDeclarationTool.FindHelpersInUsesSection(
6066 UsesNode: TCodeTreeNode; Params: TFindDeclarationParams);
6067 var
6068 NewCodeTool: TFindDeclarationTool;
6069 Node: TCodeTreeNode;
6070 AnUnitName: string;
6071 InFilename: string;
6072 begin
6073 // search in units
6074 //debugln(['TFindDeclarationTool.FindHelpersInUsesSection START ',CleanPosToStr(UsesNode.StartPos,true),' Main=',MainFilename]);
6075 Node:=UsesNode.LastChild;
6076 while Node<>nil do begin
6077 AnUnitName:=ExtractUsedUnitName(Node,@InFilename);
6078 if AnUnitName<>'' then begin
6079 //debugln(['TFindDeclarationTool.FindHelpersInUsesSection ',CleanPosToStr(Node.StartPos),' AnUnitName="',AnUnitName,'" in "',InFilename,'"']);
6080 NewCodeTool:=FindCodeToolForUsedUnit(AnUnitName,InFilename,false);
6081 if NewCodeTool<>nil then begin
6082 // search the identifier in the interface of the used unit
6083 NewCodeTool.FindHelpersInInterface(Self,Params);
6084 end;
6085 end;
6086 Node:=Node.PriorBrother;
6087 end;
6088 end;
6089
FindContextClassAndAncestorsAndExtendedClassOfHelpernull6090 function TFindDeclarationTool.FindContextClassAndAncestorsAndExtendedClassOfHelper
6091 (const CursorPos: TCodeXYPosition; var ListOfPFindContext: TFPList): boolean;
6092 // returns a list of nodes of AllClasses (ctnClass, ...)
6093 var
6094 CleanCursorPos: integer;
6095 ANode: TCodeTreeNode;
6096 ClassNode: TCodeTreeNode;
6097 ExtendedClassExpr: TExpressionType;
6098 begin
6099 Result:=false;
6100 ListOfPFindContext:=nil;
6101
6102 ActivateGlobalWriteLock;
6103 try
6104 BuildTreeAndGetCleanPos(trTillCursor,lsrEnd,CursorPos,CleanCursorPos,
6105 [btSetIgnoreErrorPos]);
6106
6107 // find class node
6108 ANode:=FindDeepestNodeAtPos(CleanCursorPos,true);
6109 if (ANode.GetNodeOfType(ctnClassInheritance)<>nil) then
6110 exit;
6111 ClassNode:=FindClassNode(ANode);
6112 if (ClassNode=nil) or (ClassNode.Parent=nil)
6113 or (not (ClassNode.Parent.Desc in [ctnTypeDefinition,ctnGenericType])) then
6114 exit;
6115
6116 //debugln('TFindDeclarationTool.FindContextClassAndAncestors A ClassName=',ExtractClassName(ClassNode,false));
6117 // add class and ancestors type definition to ListOfPCodeXYPosition
6118 if not FindClassAndAncestors(ClassNode,ListOfPFindContext,true)
6119 then exit;
6120
6121 //find extended class node
6122 ExtendedClassExpr := FindExtendedExprOfHelper(ClassNode);
6123 if ((ExtendedClassExpr.Desc=xtContext) and (ExtendedClassExpr.Context.Tool<>nil) and
6124 (ExtendedClassExpr.Context.Node<>nil) and (ExtendedClassExpr.Context.Node.Desc=ctnClass)) then
6125 begin
6126 if not ExtendedClassExpr.Context.Tool.FindClassAndAncestors(ExtendedClassExpr.Context.Node,ListOfPFindContext,true)
6127 then exit;
6128 end;
6129
6130 //debugln('TFindDeclarationTool.FindContextClassAndAncestors List: ',ListOfPFindContextToStr(ListOfPFindContext));
6131
6132 finally
6133 DeactivateGlobalWriteLock;
6134 end;
6135 Result:=true;
6136 end;
6137
FindDefaultAncestorOfClassnull6138 function TFindDeclarationTool.FindDefaultAncestorOfClass(
6139 ClassNode: TCodeTreeNode; Params: TFindDeclarationParams;
6140 FindClassContext: boolean): boolean;
6141 var
6142 OldInput: TFindDeclarationInput;
6143 AncestorNode, ClassIdentNode: TCodeTreeNode;
6144 AncestorContext: TFindContext;
6145 BaseClassName: PChar;
6146
6147 procedure RaiseBaseClassNotFound;
6148 begin
6149 MoveCursorToNodeStart(ClassNode);
6150 if BaseClassName='TObject' then
6151 RaiseException(20170421200159,ctsDefaultClassAncestorTObjectNotFound)
6152 else if BaseClassName='IInterface' then
6153 RaiseException(20170421200202,ctsDefaultInterfaceAncestorIInterfaceNotFound)
6154 else if BaseClassName='IDispatch' then
6155 RaiseException(20170421200205,ctsDefaultDispinterfaceAncestorIDispatchNotFound)
6156 else if BaseClassName='JLObject' then
6157 RaiseException(20170421200207,ctsDefaultJavaClassAncestorJLObjectNotFound)
6158 else
6159 RaiseExceptionFmt(20170421200210,ctsDefaultAncestorNotFound, [BaseClassName]);
6160 end;
6161
6162 begin
6163 //debugln(['TFindDeclarationTool.FindAncestorOfClass ',CleanPosToStr(ClassNode.StartPos,true)]);
6164 {$IFDEF CheckNodeTool}CheckNodeTool(ClassNode);{$ENDIF}
6165 if (ClassNode=nil) or (not (ClassNode.Desc in AllClasses))
6166 then
6167 RaiseException(20170421200213,'[TFindDeclarationTool.FindDefaultAncestorOfClass] '
6168 +' invalid classnode');
6169 Result:=false;
6170
6171 // ToDo: ppu, dcu
6172
6173 // no ancestor class specified
6174 ClassIdentNode:=ClassNode.Parent;
6175 // check class name
6176 if (ClassIdentNode<>nil)
6177 and (not (ClassIdentNode.Desc in [ctnTypeDefinition,ctnGenericType])) then
6178 begin
6179 debugln(['TFindDeclarationTool.FindDefaultAncestorOfClass not a type']);
6180 exit;
6181 end;
6182 BaseClassName:=nil;
6183 case ClassNode.Desc of
6184 ctnClass:
6185 if Scanner.Values.IsDefined('CPUJVM') then
6186 BaseClassName:='JLObject'
6187 else if (Scanner.PascalCompiler=pcPas2js)
6188 and (FindClassExternalNode(ClassNode)<>nil) then
6189 exit // external root class has no ancestor
6190 else
6191 BaseClassName:='TObject';
6192 ctnDispinterface:
6193 // default interface is IDispatch
6194 BaseClassName:='IDispatch';
6195 ctnClassInterface:
6196 begin
6197 if Scanner.Values.IsDefined('CPUJVM') then
6198 exit; // JVM has no default interface
6199 // Delphi has as default interface IInterface
6200 // FPC has as default interface IUnknown and an alias IInterface = IUnknown
6201 if CompareSrcIdentifiers(ClassIdentNode.StartPos,'IUnknown') then exit;
6202 BaseClassName:='IInterface';
6203 end
6204 else
6205 exit; // has no default ancestor (e.g. record)
6206 end;
6207 if CompareSrcIdentifiers(ClassIdentNode.StartPos,BaseClassName) then
6208 exit; // this is already the base class
6209
6210 {$IFDEF ShowTriedContexts}
6211 DebugLn('[TFindDeclarationTool.FindAncestorOfClass] ',
6212 ' search default ancestor class '+BaseClassName);
6213 {$ENDIF}
6214
6215 // search default ancestor
6216 Params.Save(OldInput);
6217 Params.Flags:=[fdfSearchInParentNodes,fdfIgnoreCurContextNode,
6218 fdfExceptionOnNotFound]
6219 +(fdfGlobals*Params.Flags)
6220 -[fdfTopLvlResolving];
6221 Params.SetIdentifier(Self,BaseClassName,nil);
6222 Params.ContextNode:=ClassNode;
6223 if not FindIdentifierInContext(Params) then
6224 RaiseBaseClassNotFound;
6225
6226 // check result
6227 if not (Params.NewNode.Desc in [ctnTypeDefinition,ctnGenericType]) then
6228 RaiseBaseClassNotFound;
6229
6230 // search ancestor class context
6231 if FindClassContext then begin
6232 AncestorNode:=Params.NewNode;
6233 Params.Flags:=Params.Flags+[fdfFindChildren];
6234 AncestorContext:=Params.NewCodeTool.FindBaseTypeOfNode(Params,
6235 AncestorNode);
6236 Params.SetResult(AncestorContext);
6237
6238 // check result
6239 if Params.NewNode.Desc<>ClassNode.Desc then
6240 RaiseBaseClassNotFound;
6241 end;
6242 Result:=true;
6243 Params.Load(OldInput,true);
6244 end;
6245
6246 {-------------------------------------------------------------------------------
6247 function TFindDeclarationTool.FindReferences(const CursorPos: TCodeXYPosition;
6248 SkipComments: boolean; var ListOfPCodeXYPosition: TFPList): boolean;
6249
6250 Search for all identifiers in current unit, referring to the declaration
6251 at CursorPos.
6252 -------------------------------------------------------------------------------}
FindReferencesnull6253 function TFindDeclarationTool.FindReferences(const CursorPos: TCodeXYPosition;
6254 SkipComments: boolean; out ListOfPCodeXYPosition: TFPList): boolean;
6255 var
6256 DeclarationFound: boolean;
6257 Identifier: string;
6258 CleanDeclCursorPos: integer;
6259 DeclarationTool: TFindDeclarationTool;
6260 DeclarationNode: TCodeTreeNode;
6261 AliasDeclarationNode: TCodeTreeNode; // if exists: always in front of DeclarationNode
6262 Params: TFindDeclarationParams;
6263 PosTree: TAVLTree; // tree of PChar positions in Src
6264 ReferencePos: TCodeXYPosition;
6265 MinPos, MaxPos: Integer;
6266 CursorNode: TCodeTreeNode;
6267 UnitStartFound, Found: Boolean;
6268 StartPos: integer; // keep this here, it is modified at several places
6269
6270 procedure AddReference(ACleanPos: integer);
6271 var
6272 p: PChar;
6273 begin
6274 if PosTree=nil then
6275 PosTree:=TAVLTree.Create;
6276 p:=@Src[ACleanPos];
6277 //debugln('TFindDeclarationTool.FindReferences.AddReference ',CleanPosToStr(ACleanPos),' ',dbgs(PosTree.Find(p)=nil),' Code=',dbgstr(copy(Src,ACleanPos-8,8)+'|'+dbgstr(copy(Src,ACleanPos,5))));
6278 if PosTree.Find(p)=nil then
6279 PosTree.Add(p);
6280 end;
6281
6282 procedure AddNodeReference(Node: TCodeTreeNode);
6283 var
6284 p: LongInt;
6285 begin
6286 p:=Node.StartPos;
6287 if Node.Desc in [ctnProcedure,ctnProcedureHead] then begin
6288 MoveCursorToProcName(Node,true);
6289 p:=CurPos.StartPos;
6290 end else if Node.Desc in [ctnProperty,ctnGlobalProperty] then begin
6291 MoveCursorToPropName(Node);
6292 p:=CurPos.StartPos;
6293 end;
6294 AddReference(p);
6295 end;
6296
6297 procedure UseProcHead(var Node: TCodeTreeNode);
6298 begin
6299 if Node=nil then exit;
6300 if (Node.Desc=ctnProcedure)
6301 and (Node.FirstChild<>nil)
6302 and (Node.FirstChild.Desc=ctnProcedureHead) then
6303 Node:=Node.FirstChild;
6304 end;
6305
6306 procedure ReadIdentifier(IsComment: boolean);
6307 var
6308 IdentStartPos: Integer;
6309 IdentEndPos: integer;
6310 begin
6311 if (not IsComment) then
6312 UnitStartFound:=true;
6313 IdentStartPos:=StartPos;
6314 IdentEndPos:=IdentStartPos;
6315 while (IdentEndPos<=MaxPos) and (IsIdentChar[Src[IdentEndPos]]) do
6316 inc(IdentEndPos);
6317 StartPos:=IdentEndPos;
6318 //debugln(['ReadIdentifier ',CleanPosToStr(IdentStartPos,true),' ',copy(Src,IdentStartPos,IdentEndPos-IdentStartPos),' ',CompareIdentifiers(PChar(Pointer(Identifier)),@Src[IdentStartPos])]);
6319 if IdentEndPos-IdentStartPos<>length(Identifier) then exit;
6320 if CompareIdentifiers(PChar(Pointer(Identifier)),@Src[IdentStartPos])<>0 then exit;
6321 if IsComment and (SkipComments or (not UnitStartFound)) then exit;
6322 {debugln(['Identifier with same name found at: ',
6323 IdentStartPos,'=',CleanPosToStr(StartPos),' ',GetIdentifier(@Src[IdentStartPos]),
6324 ' CleanDeclCursorPos=',CleanDeclCursorPos,
6325 ' MaxPos=',MaxPos,
6326 ' IsComment=',IsComment,
6327 ' SkipComments=',SkipComments,
6328 ' UnitStartFound=',UnitStartFound
6329 ]);}
6330
6331 CursorNode:=BuildSubTreeAndFindDeepestNodeAtPos(IdentStartPos,true);
6332 //debugln(' CursorNode=',CursorNode.DescAsString,' Forward=',dbgs(CursorNode.SubDesc and ctnsForwardDeclaration));
6333
6334 if (DeclarationTool=Self)
6335 and ((IdentStartPos=CleanDeclCursorPos) or (CursorNode=AliasDeclarationNode))
6336 then begin
6337 // declaration itself found
6338 //debugln(['ReadIdentifier declaration itself found, adding ...']);
6339 AddReference(IdentStartPos)
6340 end
6341 else if CleanPosIsDeclarationIdentifier(IdentStartPos,CursorNode) then
6342 // this identifier is another declaration with the same name
6343 else begin
6344 // find declaration
6345 if Params=nil then
6346 Params:=TFindDeclarationParams.Create(Self, CursorNode)
6347 else
6348 Params.Clear;
6349 Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors,fdfSearchInHelpers,
6350 fdfIgnoreCurContextNode];
6351 Params.ContextNode:=CursorNode;
6352 //debugln(copy(Src,Params.ContextNode.StartPos,200));
6353 Params.SetIdentifier(Self,@Src[IdentStartPos],@CheckSrcIdentifier);
6354
6355 // search identifier in comment -> if not found, this is no bug
6356 // => silently ignore
6357 try
6358 Found:=FindDeclarationOfIdentAtParam(Params);
6359 except
6360 on E: ECodeToolError do begin
6361 if E.Sender<>Self then begin
6362 // there is an error in another unit, which prevents searching
6363 // stop further searching in this unit
6364 raise;
6365 end;
6366 // continue
6367 end;
6368 on E: Exception do
6369 raise;
6370 end;
6371
6372 //debugln(' Found=',dbgs(Found));
6373 if Found and (Params.NewNode<>nil) then begin
6374 UseProcHead(Params.NewNode);
6375 //debugln('Context=',Params.NewNode.DescAsString,' ',dbgs(Params.NewNode.StartPos),' ',dbgs(DeclarationNode.StartPos));
6376 if (Params.NewNode=DeclarationNode)
6377 or (Params.NewNode=AliasDeclarationNode) then begin
6378 //debugln(['ReadIdentifier reference found, adding ...']);
6379 AddReference(IdentStartPos);
6380 end;
6381 end;
6382 end;
6383 end;
6384
6385 procedure SearchIdentifiers;
6386 var
6387 CommentLvl: Integer;
6388 InStrConst: Boolean;
6389 begin
6390 StartPos:=MinPos;
6391 UnitStartFound:=false;
6392 while StartPos<=MaxPos do begin
6393 case Src[StartPos] of
6394
6395 '{':
6396 begin
6397 inc(StartPos);
6398 if (StartPos<=MaxPos) and (Src[StartPos]=#3) then begin
6399 // codetools skip comment {#3 #3}
6400 inc(StartPos);
6401 while (StartPos<=MaxPos) do begin
6402 if (Src[StartPos]=#3) and (StartPos<MaxPos) and (Src[StartPos+1]='}')
6403 then begin
6404 inc(StartPos,2);
6405 break;
6406 end;
6407 inc(StartPos);
6408 end;
6409 end else begin
6410 // pascal comment {}
6411 CommentLvl:=1;
6412 InStrConst:=false;
6413 while StartPos<=MaxPos do begin
6414 case Src[StartPos] of
6415 '{': if Scanner.NestedComments then inc(CommentLvl);
6416 '}':
6417 begin
6418 dec(CommentLvl);
6419 if CommentLvl=0 then break;
6420 end;
6421 'a'..'z','A'..'Z','_':
6422 if not InStrConst then begin
6423 ReadIdentifier(true);
6424 dec(StartPos);
6425 end;
6426 '''':
6427 InStrConst:=not InStrConst;
6428 #10,#13:
6429 InStrConst:=false;
6430 end;
6431 inc(StartPos);
6432 end;
6433 inc(StartPos);
6434 //debugln(StartPos,' ',copy(Src,CommentStart,StartPos-CommentStart));
6435 end;
6436 end;
6437
6438 '/': // Delphi comment
6439 if (Src[StartPos+1]<>'/') then begin
6440 inc(StartPos);
6441 end else begin
6442 inc(StartPos,2);
6443 InStrConst:=false;
6444 while (StartPos<=MaxPos) do begin
6445 case Src[StartPos] of
6446 #10,#13:
6447 break;
6448 'a'..'z','A'..'Z','_':
6449 if not InStrConst then begin
6450 ReadIdentifier(true);
6451 dec(StartPos);
6452 end;
6453 '''':
6454 InStrConst:=not InStrConst;
6455 end;
6456 inc(StartPos);
6457 end;
6458 inc(StartPos);
6459 if (StartPos<=MaxPos) and (Src[StartPos] in [#10,#13])
6460 and (Src[StartPos-1]<>Src[StartPos]) then
6461 inc(StartPos);
6462 end;
6463
6464 '(': // turbo pascal comment
6465 if (Src[StartPos+1]<>'*') then begin
6466 inc(StartPos);
6467 end else begin
6468 inc(StartPos,3);
6469 InStrConst:=false;
6470 while (StartPos<=MaxPos) do begin
6471 case Src[StartPos] of
6472 ')':
6473 if Src[StartPos-1]='*' then break;
6474 'a'..'z','A'..'Z','_':
6475 if not InStrConst then begin
6476 ReadIdentifier(true);
6477 dec(StartPos);
6478 end;
6479 '''':
6480 InStrConst:=not InStrConst;
6481 #10,#13:
6482 InStrConst:=false;
6483 end;
6484 inc(StartPos);
6485 end;
6486 inc(StartPos);
6487 end;
6488
6489 'a'..'z','A'..'Z','_':
6490 ReadIdentifier(false);
6491
6492 '''':
6493 begin
6494 // skip string constant
6495 inc(StartPos);
6496 while (StartPos<=MaxPos) do begin
6497 if (not (Src[StartPos] in ['''',#10,#13])) then
6498 inc(StartPos)
6499 else begin
6500 inc(StartPos);
6501 break;
6502 end;
6503 end;
6504 end;
6505
6506 else
6507 inc(StartPos);
6508 end;
6509 end;
6510 end;
6511
GetDeclarationToolnull6512 function GetDeclarationTool: boolean;
6513 begin
6514 Result:=false;
6515 DeclarationTool:=nil;
6516 if Assigned(FOnGetCodeToolForBuffer) then
6517 DeclarationTool:=FOnGetCodeToolForBuffer(Self,CursorPos.Code,true)
6518 else if CursorPos.Code=TObject(Scanner.MainCode) then
6519 DeclarationTool:=Self;
6520 if DeclarationTool=nil then begin
6521 debugln('WARNING: TFindDeclarationTool.FindReferences DeclarationTool=nil');
6522 exit;
6523 end;
6524 Result:=true;
6525 end;
6526
FindDeclarationNodenull6527 function FindDeclarationNode: boolean;
6528 const
6529 ProcAttr = [phpInUpperCase,phpAddClassName,phpWithVarModifiers];
6530 var
6531 Node: TCodeTreeNode;
6532 CommentStart: integer;
6533 CommentEnd: integer;
6534 p: LongInt;
6535 begin
6536 if DeclarationFound then exit(true);
6537 Result:=false;
6538
6539 // find the main declaration node and identifier
6540 DeclarationTool.BuildTreeAndGetCleanPos(CursorPos,CleanDeclCursorPos);
6541 DeclarationNode:=DeclarationTool.BuildSubTreeAndFindDeepestNodeAtPos(
6542 CleanDeclCursorPos,true);
6543 Identifier:=DeclarationTool.ExtractIdentifier(CleanDeclCursorPos);
6544 if Identifier='' then begin
6545 //debugln('FindDeclarationNode Identifier="',Identifier,'"');
6546 exit;
6547 end;
6548 UseProcHead(DeclarationNode);
6549 if DeclarationTool=Self then begin
6550 //debugln(['FindDeclarationNode adding DeclarationNode ...']);
6551 AddNodeReference(DeclarationNode);
6552 end;
6553
6554 // find alias declaration node
6555 //debugln('FindDeclarationNode DeclarationNode=',DeclarationNode.DescAsString);
6556 AliasDeclarationNode:=nil;
6557 case DeclarationNode.Desc of
6558
6559 ctnProcedure,ctnProcedureHead:
6560 begin
6561 Node:=DeclarationNode;
6562 if DeclarationNode.Desc=ctnProcedureHead then
6563 Node:=Node.Parent;
6564 AliasDeclarationNode:=DeclarationTool.FindCorrespondingProcNode(
6565 Node,ProcAttr);
6566 end;
6567
6568 ctnVarDefinition:
6569 if DeclarationNode.HasParentOfType(ctnProcedureHead) then begin
6570 AliasDeclarationNode:=FindCorrespondingProcParamNode(DeclarationNode,ProcAttr);
6571 end;
6572
6573 ctnTypeDefinition:
6574 if NodeIsForwardType(DeclarationNode) then
6575 AliasDeclarationNode:=DeclarationTool.FindTypeOfForwardNode(DeclarationNode)
6576 else
6577 AliasDeclarationNode:=DeclarationTool.FindForwardTypeNode(DeclarationNode,true);
6578
6579 end;
6580 if AliasDeclarationNode=DeclarationNode then
6581 AliasDeclarationNode:=nil;
6582
6583 if AliasDeclarationNode<>nil then begin
6584 UseProcHead(AliasDeclarationNode);
6585 if DeclarationTool=Self then begin
6586 //debugln(['FindDeclarationNode adding alias node ...']);
6587 AddNodeReference(AliasDeclarationNode);
6588 end;
6589 if AliasDeclarationNode.StartPos>DeclarationNode.StartPos then begin
6590 Node:=AliasDeclarationNode;
6591 AliasDeclarationNode:=DeclarationNode;
6592 DeclarationNode:=Node;
6593 end;
6594 //debugln('FindDeclarationNode AliasDeclarationNode=',AliasDeclarationNode.DescAsString,' ',DeclarationTool.CleanPosToStr(AliasDeclarationNode.StartPos,DeclarationTool<>Self));
6595 end;
6596
6597 // search comment in front of declaration
6598 //debugln(['FindDeclarationNode search comment in front: ',DeclarationTool=Self,' SkipComments=',SkipComments,' Identifier=',Identifier]);
6599 if (DeclarationTool=Self)
6600 and (not SkipComments)
6601 and FindCommentInFront(DeclarationNode.StartPos,Identifier,
6602 true,false,false,true,true,CommentStart,CommentEnd)
6603 then begin
6604 //debugln(['FindDeclarationNode Comment="',dbgstr(copy(Src,CommentStart,CommentEnd)),'"']);
6605 p:=CommentStart;
6606 if (Src[p]='{') then begin
6607 inc(p);
6608 while (p<=SrcLen) and IsSpaceChar[Src[p]] do inc(p);
6609 if (p<=SrcLen) and (CompareIdentifiers(@Src[p],PChar(Identifier))=0)
6610 then begin
6611 //debugln(['FindDeclarationNode comment in front']);
6612 AddReference(p);
6613 end;
6614 end;
6615 end;
6616
6617 DeclarationFound:=true;
6618 Result:=true;
6619 end;
6620
6621 procedure LimitScope(UseNode: TCodeTreeNode);
6622 var
6623 Node: TCodeTreeNode;
6624 StartNode: TCodeTreeNode;
6625 begin
6626 MinPos:=Tree.FindFirstPosition;
6627 MaxPos:=Tree.FindLastPosition;
6628 if MaxPos>SrcLen then MaxPos:=SrcLen;
6629
6630 if DeclarationTool<>Self then begin
6631 MinPos:=UseNode.Parent.EndPos;
6632 exit;
6633 end;
6634
6635 StartNode:=DeclarationNode;
6636 if (AliasDeclarationNode<>nil) then
6637 StartNode:=AliasDeclarationNode;
6638 Node:=StartNode;
6639 while Node<>nil do begin
6640 case Node.Desc of
6641 ctnImplementation:
6642 // only search in implementation
6643 if MinPos<Node.StartPos then MinPos:=Node.StartPos;
6644
6645 ctnTypeDefinition:
6646 begin
6647 // Note: types can be used before declaration
6648 end;
6649
6650 ctnVarDefinition,ctnConstDefinition,ctnEnumIdentifier,ctnLabel:
6651 begin
6652 // only search behind variable
6653 if MinPos<Node.StartPos then MinPos:=Node.StartPos;
6654 end;
6655
6656 ctnProcedureHead:
6657 MinPos:=Node.StartPos;
6658
6659 ctnProcedure:
6660 begin
6661 if (FindProcBody(Node)<>nil) and (StartNode<>Node.FirstChild) then
6662 begin
6663 // DeclarationNode is a local identifier
6664 // limit scope to procedure
6665 //debugln(['LimitScope ProcNode=',CleanPosToStr(Node.StartPos),'..',CleanPosToStr(Node.EndPos)]);
6666 if MinPos<Node.FirstChild.EndPos then
6667 MinPos:=Node.FirstChild.EndPos;
6668 if MaxPos>Node.EndPos then
6669 MaxPos:=Node.EndPos;
6670 end;
6671 end;
6672
6673 ctnOnBlock:
6674 begin
6675 // a declaration in an on block is only accessible in the on block
6676 if MinPos<Node.StartPos then
6677 MinPos:=Node.StartPos;
6678 if MaxPos>Node.EndPos then
6679 MaxPos:=Node.EndPos;
6680 end;
6681
6682 end;
6683 //debugln(['scope limited to node: ',Node.DescAsString,' ',CleanPosToStr(MinPos),'..',CleanPosToStr(MaxPos),': ',dbgstr(copy(Src,MinPos,20)),'..',dbgstr(copy(Src,MaxPos-20,20))]);
6684 Node:=Node.Parent;
6685 end;
6686 //debugln(['LimitScope ',CleanPosToStr(MinPos),'..',CleanPosToStr(MaxPos),': ',dbgstr(copy(Src,MinPos,20)),'..',dbgstr(copy(Src,MaxPos-20,20))]);
6687 end;
6688
6689 var
6690 UseNode: TCodeTreeNode;
6691 AVLNode: TAVLTreeNode;
6692 begin
6693 Result:=false;
6694 //debugln('FindReferences ',MainFilename,' CursorPos=',CursorPos.Code.Filename,' x=',dbgs(CursorPos.X),' y=',dbgs(CursorPos.Y),' SkipComments=',dbgs(SkipComments));
6695
6696 ListOfPCodeXYPosition:=nil;
6697 Params:=nil;
6698 PosTree:=nil;
6699 DeclarationFound:=false;
6700
6701 ActivateGlobalWriteLock;
6702 try
6703 // get the tool of the declaration
6704 if not GetDeclarationTool then exit;
6705
6706 // check if this unit uses the declaration unit
6707 UseNode:=nil;
6708 if Self<>DeclarationTool then begin
6709 BuildTree(lsrImplementationUsesSectionEnd);
6710 UseNode:=FindUnitFileInAllUsesSections(DeclarationTool.MainFilename);
6711 if UseNode=nil then
6712 exit(true); // the declaration unit is not used
6713 end;
6714
6715 // find declaration nodes and identifier
6716 BuildTree(lsrEnd);
6717 if not FindDeclarationNode then exit;
6718
6719 // search identifiers
6720 LimitScope(UseNode);
6721
6722 //debugln('FindReferences MinPos=',CleanPosToStr(MinPos),' MaxPos=',CleanPosToStr(MaxPos));
6723 SearchIdentifiers;
6724
6725 // create the reference list
6726 if PosTree<>nil then begin
6727 AVLNode:=PosTree.FindHighest;
6728 while AVLNode<>nil do begin
6729 StartPos:=PChar(AVLNode.Data)-PChar(Pointer(Src))+1;
6730 // Note: if an include file is included twice a code position could be duplicated
6731 if CleanPosToCaret(StartPos,ReferencePos) then
6732 AddCodePosition(ListOfPCodeXYPosition,ReferencePos);
6733 AVLNode:=PosTree.FindPrecessor(AVLNode);
6734 end;
6735 end;
6736
6737 finally
6738 Params.Free;
6739 PosTree.Free;
6740 DeactivateGlobalWriteLock;
6741 end;
6742 Result:=true;
6743 end;
6744
FindUnitReferencesnull6745 function TFindDeclarationTool.FindUnitReferences(UnitCode: TCodeBuffer;
6746 SkipComments: boolean; out ListOfPCodeXYPosition: TFPList): boolean;
6747 var
6748 AUnitName, UpperUnitName: String;
6749
CheckUsesSectionnull6750 function CheckUsesSection(UsesNode: TCodeTreeNode; out Found: boolean): boolean;
6751 var
6752 ReferencePos: TCodeXYPosition;
6753 begin
6754 Result:=true;
6755 Found:=false;
6756 if UsesNode=nil then exit;
6757 //DebugLn(['CheckUsesSection ']);
6758 MoveCursorToNodeStart(UsesNode);
6759 if (UsesNode.Desc=ctnUsesSection) then begin
6760 ReadNextAtom;
6761 if not UpAtomIs('USES') then
6762 RaiseUsesExpected(20170421200509);
6763 end;
6764 repeat
6765 ReadNextAtom; // read name
6766 if CurPos.StartPos>SrcLen then break;
6767 if AtomIsChar(';') then break;
6768 AtomIsIdentifierE;
6769 //DebugLn(['CheckUsesSection ',GetAtom,' ',AUnitName]);
6770 if UpAtomIs(UpperUnitName) then begin // compare case insensitive
6771 if CleanPosToCaret(CurPos.StartPos,ReferencePos) then begin
6772 //DebugLn(['CheckUsesSection found in uses section: ',Dbgs(ReferencePos)]);
6773 Found:=true;
6774 AddCodePosition(ListOfPCodeXYPosition,ReferencePos);
6775 end;
6776 end;
6777 ReadNextAtom;
6778 if UpAtomIs('IN') then begin
6779 ReadNextAtom;
6780 if not AtomIsStringConstant then RaiseStrConstExpected(20170421200522);
6781 ReadNextAtom;
6782 end;
6783 if AtomIsChar(';') then break;
6784 if not AtomIsChar(',') then
6785 RaiseExceptionFmt(20170421200217,ctsStrExpectedButAtomFound,[';',GetAtom])
6786 until (CurPos.StartPos>SrcLen);
6787 end;
6788
CheckSourcenull6789 function CheckSource(StartPos: integer): boolean;
6790 var
6791 ReferencePos: TCodeXYPosition;
6792 begin
6793 MoveCursorToCleanPos(StartPos);
6794 repeat
6795 ReadNextAtom;
6796 if not SkipComments then
6797 ; // ToDo
6798 if UpAtomIs(UpperUnitName)
6799 and not LastAtomIs(0,'.') then begin
6800 if CleanPosToCaret(CurPos.StartPos,ReferencePos) then begin
6801 //DebugLn(['CheckSource found: ',Dbgs(ReferencePos)]);
6802 AddCodePosition(ListOfPCodeXYPosition,ReferencePos);
6803 end;
6804 end;
6805 until CurPos.StartPos>SrcLen;
6806 Result:=true;
6807 end;
6808
6809 var
6810 InterfaceUsesNode: TCodeTreeNode;
6811 ImplementationUsesNode: TCodeTreeNode;
6812 Found: boolean;
6813 StartPos: Integer;
6814 begin
6815 Result:=false;
6816 //debugln('FindUnitReferences UnitCode=',UnitCode.Filename,' SkipComments=',dbgs(SkipComments),' ',MainFilename);
6817
6818 AUnitName:=ExtractFileNameOnly(UnitCode.Filename);
6819 UpperUnitName:=UpperCaseStr(AUnitName);
6820 ListOfPCodeXYPosition:=nil;
6821 ActivateGlobalWriteLock;
6822 try
6823 BuildTree(lsrEnd);
6824
6825 InterfaceUsesNode:=FindMainUsesNode;
6826 if not CheckUsesSection(InterfaceUsesNode,Found) then exit;
6827
6828 StartPos:=-1;
6829 if Found then begin
6830 StartPos:=InterfaceUsesNode.EndPos;
6831 end else begin
6832 ImplementationUsesNode:=FindImplementationUsesNode;
6833 if not CheckUsesSection(ImplementationUsesNode,Found) then exit;
6834 if Found then
6835 StartPos:=ImplementationUsesNode.EndPos;
6836 end;
6837
6838 // find unit reference in source
6839 if StartPos>0 then begin
6840 if not CheckSource(StartPos) then exit;
6841 end;
6842 finally
6843 DeactivateGlobalWriteLock;
6844 end;
6845 Result:=true;
6846 end;
6847
6848 procedure TFindDeclarationTool.FindUsedUnitReferences(
6849 const CursorPos: TCodeXYPosition; SkipComments: boolean; out
6850 UsedUnitFilename: string; out ListOfPCodeXYPosition: TFPList);
6851 var
6852 CleanPos: integer;
6853 Node: TCodeTreeNode;
6854 UnitInFilename: string;
6855 AnUnitName: String;
6856 TargetCode: TCodeBuffer;
6857 TargetTool: TFindDeclarationTool;
6858 begin
6859 //debugln(['TFindDeclarationTool.FindUsedUnitReferences ',dbgs(CursorPos)]);
6860 UsedUnitFilename:='';
6861 ListOfPCodeXYPosition:=nil;
6862 BuildTreeAndGetCleanPos(CursorPos,CleanPos);
6863 Node:=FindDeepestNodeAtPos(CleanPos,true);
6864 if Node.Desc in [ctnUseUnitNamespace,ctnUseUnitClearName] then
6865 Node:=Node.Parent;
6866 if Node.Desc<>ctnUseUnit then
6867 RaiseException(20170421200221,'This function needs the cursor at a unit in a uses clause');
6868 // cursor is on an used unit -> try to locate it
6869 MoveCursorToCleanPos(Node.StartPos);
6870 ReadNextAtom;
6871 AnUnitName:=ExtractUsedUnitNameAtCursor(@UnitInFilename);
6872 //debugln(['TFindDeclarationTool.FindUsedUnitReferences Used Unit=',AnUnitName,' in "',UnitInFilename,'"']);
6873 TargetCode:=FindUnitSource(AnUnitName,UnitInFilename,true,Node.StartPos);
6874 UsedUnitFilename:=TargetCode.Filename;
6875 //debugln(['TFindDeclarationTool.FindUsedUnitReferences TargetCode=',TargetCode.Filename]);
6876 TargetTool:=FOnGetCodeToolForBuffer(Self,TargetCode,false);
6877 FindUsedUnitReferences(TargetTool,SkipComments,ListOfPCodeXYPosition);
6878 end;
6879
6880 procedure TFindDeclarationTool.FindUsedUnitReferences(
6881 TargetTool: TFindDeclarationTool; SkipComments: boolean; out
6882 ListOfPCodeXYPosition: TFPList);
6883 var
6884 refs: TFindUsedUnitReferences;
6885 begin
6886 ListOfPCodeXYPosition:=TFPList.Create;
6887 if TargetTool=nil then
6888 RaiseException(20170421200226,'TargetTool=nil');
6889 TargetTool.BuildInterfaceIdentifierCache(true);
6890 refs:=TFindUsedUnitReferences.Create(Self, FindLastNode);
6891 try
6892 refs.TargetTool:=TargetTool;
6893 refs.TargetUnitName:=TargetTool.GetSourceName(false);
6894 refs.ListOfPCodeXYPosition:=ListOfPCodeXYPosition;
6895 ForEachIdentifier(SkipComments,@OnFindUsedUnitIdentifier,refs);
6896 finally
6897 refs.Free;
6898 end;
6899 end;
6900
6901 {-------------------------------------------------------------------------------
6902 function TFindDeclarationTool.CleanPosIsDeclarationIdentifier(CleanPos: integer;
6903 Node: TCodeTreeNode): boolean;
6904
6905 Node should be the deepest node at CleanPos, and all sub trees built.
6906 See BuildSubTree
6907 -------------------------------------------------------------------------------}
CleanPosIsDeclarationIdentifiernull6908 function TFindDeclarationTool.CleanPosIsDeclarationIdentifier(CleanPos: integer;
6909 Node: TCodeTreeNode): boolean;
6910
InNodeIdentifiernull6911 function InNodeIdentifier(NodeIdentStartPos: Integer): boolean;
6912 var
6913 IdentStartPos, IdentEndPos: integer;
6914 begin
6915 GetIdentStartEndAtPosition(Src,CleanPos,IdentStartPos,IdentEndPos);
6916 Result:=(IdentEndPos>IdentStartPos) and (IdentStartPos=NodeIdentStartPos);
6917 end;
6918
6919 begin
6920 {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF}
6921 Result:=false;
6922 if Node=nil then exit;
6923 case Node.Desc of
6924
6925 ctnTypeDefinition,ctnVarDefinition,ctnConstDefinition,ctnEnumIdentifier,ctnLabel:
6926 begin
6927 if NodeIsForwardDeclaration(Node) then exit;
6928 Result:=InNodeIdentifier(Node.StartPos);
6929 end;
6930
6931 ctnGenericType:
6932 begin
6933 if (Node.FirstChild=nil) or NodeIsForwardDeclaration(Node) then exit;
6934 Result:=InNodeIdentifier(Node.FirstChild.StartPos);
6935 end;
6936
6937 ctnProcedure:
6938 begin
6939 if (Node.FirstChild<>nil)
6940 and ((Node.FirstChild.SubDesc and ctnsForwardDeclaration)>0) then
6941 RaiseException(20170421200230,'TFindDeclarationTool.CleanPosIsDeclarationIdentifier Node not expanded');
6942 MoveCursorToProcName(Node,true);
6943 Result:=InNodeIdentifier(CurPos.StartPos);
6944 end;
6945
6946 ctnProcedureHead:
6947 begin
6948 MoveCursorToProcName(Node,true);
6949 Result:=InNodeIdentifier(CurPos.StartPos);
6950 end;
6951
6952 ctnProperty, ctnGlobalProperty:
6953 begin
6954 if not MoveCursorToPropName(Node) then exit;
6955 Result:=InNodeIdentifier(CurPos.StartPos);
6956 end;
6957
6958 ctnUnit:
6959 Result:=PositionInSourceName(CleanPos);
6960 end;
6961 end;
6962
JumpToNodenull6963 function TFindDeclarationTool.JumpToNode(ANode: TCodeTreeNode; out
6964 NewPos: TCodeXYPosition; out NewTopLine, BlockTopLine,
6965 BlockBottomLine: integer; IsCodeBlock: boolean): boolean;
6966 var
6967 JumpPos: LongInt;
6968 Caret: TCodeXYPosition;
6969 begin
6970 {$IFDEF CheckNodeTool}CheckNodeTool(ANode);{$ENDIF}
6971 Result:=false;
6972 if (ANode=nil) or (ANode.StartPos<1) then exit;
6973 JumpPos:=ANode.StartPos;
6974 if ANode.Desc in [ctnProperty,ctnGlobalProperty] then begin
6975 MoveCursorToPropName(ANode);
6976 JumpPos:=CurPos.StartPos;
6977 end;
6978 Result:=JumpToCleanPos(JumpPos,JumpPos,ANode.EndPos,
6979 NewPos,NewTopLine,BlockTopLine,BlockBottomLine,IsCodeBlock);
6980 if CleanPosToCaret(ANode.StartPos, Caret) then
6981 BlockTopLine := Caret.Y
6982 else
6983 BlockTopLine := -1;
6984 if CleanPosToCaret(ANode.EndPos, Caret) then
6985 BlockBottomLine := Caret.Y
6986 else
6987 BlockBottomLine := -1;
6988 end;
6989
JumpToNodenull6990 function TFindDeclarationTool.JumpToNode(ANode: TCodeTreeNode; out
6991 NewPos: TCodeXYPosition; out NewTopLine: integer; IsCodeBlock: boolean
6992 ): boolean;
6993 var
6994 BlockTopLine, BlockBottomLine: integer;
6995 begin
6996 Result := JumpToNode(ANode, NewPos, NewTopLine, BlockTopLine, BlockBottomLine, IsCodeBlock);
6997 end;
6998
JumpToCleanPosnull6999 function TFindDeclarationTool.JumpToCleanPos(NewCleanPos, NewTopLineCleanPos,
7000 NewBottomLineCleanPos: integer; out NewPos: TCodeXYPosition; out NewTopLine,
7001 BlockTopLine, BlockBottomLine: integer; IsCodeBlock: boolean): boolean;
7002 var
7003 NewTopLinePos: TCodeXYPosition;
7004 NewBottomLinePos: TCodeXYPosition;
7005 JumpPos: Integer;
7006 begin
7007 Result:=false;
7008 // convert clean position to line, column and code
7009 if not CleanPosToCaret(NewCleanPos,NewPos) then exit;
7010 NewTopLine:=NewPos.Y;
7011 if AdjustTopLineDueToComment then begin
7012 // if there is a comment in front of the top position, it probably belongs
7013 // to the destination code
7014 // -> adjust the topline position, so that the comment is visible
7015 NewTopLineCleanPos:=FindLineEndOrCodeInFrontOfPosition(NewTopLineCleanPos,
7016 false);
7017 if (NewTopLineCleanPos>=1) and (Src[NewTopLineCleanPos] in [#13,#10])
7018 then begin
7019 inc(NewTopLineCleanPos);
7020 if (Src[NewTopLineCleanPos] in [#10,#13])
7021 and (Src[NewTopLineCleanPos]<>Src[NewTopLineCleanPos-1]) then
7022 inc(NewTopLineCleanPos);
7023 end;
7024 end;
7025 // convert clean top line position to line, column and code
7026 if not CleanPosToCaret(NewTopLineCleanPos,NewTopLinePos) then exit;
7027 BlockTopLine := NewTopLinePos.Y;
7028 // convert clean bottom line position to line, column and code
7029 NewBottomLinePos:=NewPos;
7030 if (NewBottomLineCleanPos>NewCleanPos)
7031 and (not CleanPosToCaret(NewBottomLineCleanPos,NewBottomLinePos)) then exit;
7032 BlockBottomLine := NewBottomLinePos.Y;
7033
7034 if NewTopLinePos.Code=NewPos.Code then begin
7035 // center the destination position in the source editor
7036 if IsCodeBlock and (JumpCodeBlockPos>0) then
7037 JumpPos := JumpCodeBlockPos
7038 else
7039 if not IsCodeBlock and (JumpSingleLinePos>0) then
7040 JumpPos := JumpSingleLinePos
7041 else
7042 JumpPos := 0;
7043 if JumpPos>0 then
7044 NewTopLine:=NewTopLinePos.Y-((VisibleEditorLines-(NewBottomLinePos.Y-NewTopLinePos.Y))*JumpPos div 100)
7045 else
7046 NewTopLine:=High(NewTopLine);
7047 if NewTopLine>NewTopLinePos.Y then
7048 NewTopLine:=NewTopLinePos.Y;
7049
7050 // NewTopLine not above first line of code
7051 if NewTopLine<1 then NewTopLine:=1;
7052 // make NewTopLine visible
7053 if NewTopLine<=NewPos.Y-VisibleEditorLines then begin
7054 // NewTopLine is not visible
7055 // center or align to bottom
7056 if (NewBottomLineCleanPos>NewCleanPos)
7057 and (NewBottomLinePos.Y<NewPos.Y+(VisibleEditorLines div 2))
7058 then begin
7059 // align to bottom
7060 NewTopLine:=NewBottomLinePos.Y-VisibleEditorLines+1;
7061 end else begin
7062 // center
7063 NewTopLine:=NewPos.Y-(VisibleEditorLines*JumpSingleLinePos div 100);
7064 end;
7065 if NewTopLine<1 then NewTopLine:=1;
7066 end;
7067 end else
7068 NewTopLine:=1;
7069 Result:=true;
7070 end;
7071
JumpToCleanPosnull7072 function TFindDeclarationTool.JumpToCleanPos(NewCleanPos, NewTopLineCleanPos,
7073 NewBottomLineCleanPos: integer; out NewPos: TCodeXYPosition; out
7074 NewTopLine: integer; IsCodeBlock: boolean): boolean;
7075 var
7076 BlockTopLine, BlockBottomLine: integer;
7077 begin
7078 Result := JumpToCleanPos(NewCleanPos, NewTopLineCleanPos, NewBottomLineCleanPos,
7079 NewPos, NewTopLine, BlockTopLine, BlockBottomLine, IsCodeBlock);
7080 end;
7081
NodeIsForwardDeclarationnull7082 function TFindDeclarationTool.NodeIsForwardDeclaration(Node: TCodeTreeNode
7083 ): boolean;
7084 var
7085 TypeNode: TCodeTreeNode;
7086 begin
7087 {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF}
7088 Result:=false;
7089 if (Node=nil) or (not (Node.Desc in [ctnTypeDefinition,ctnGenericType])) then
7090 exit;
7091 TypeNode:=FindTypeNodeOfDefinition(Node);
7092 if TypeNode=nil then exit;
7093 if TypeNode.Desc in AllClasses then begin
7094 if (TypeNode.SubDesc and ctnsForwardDeclaration)>0 then begin
7095 Result:=true;
7096 exit;
7097 end;
7098 end;
7099 end;
7100
GetExpandedOperandnull7101 function TFindDeclarationTool.GetExpandedOperand(const CursorPos: TCodeXYPosition;
7102 out Operand: string; ResolveProperty: Boolean): Boolean;
7103 var
7104 CursorNode: TCodeTreeNode;
7105 CleanCursorPos: integer;
7106 Params: TFindDeclarationParams;
7107 Identifier: PChar;
7108 LineRange: TLineRange;
7109 begin
7110 Result := False;
7111 Operand := '';
7112 if (CursorPos.Y<1) or (CursorPos.Y>CursorPos.Code.LineCount)
7113 or (CursorPos.X<1) then Exit;
7114 CursorPos.Code.GetLineRange(CursorPos.Y-1,LineRange);
7115 if LineRange.EndPos-LineRange.StartPos+1<CursorPos.X then Exit;
7116
7117 ActivateGlobalWriteLock;
7118 try
7119 // build code tree
7120 BuildTreeAndGetCleanPos(trTillCursor,lsrEnd,CursorPos,CleanCursorPos,
7121 [btSetIgnoreErrorPos,btCursorPosOutAllowed]);
7122 // find CodeTreeNode at cursor
7123 if (Tree.Root<>nil) and (Tree.Root.StartPos<=CleanCursorPos) then
7124 CursorNode := BuildSubTreeAndFindDeepestNodeAtPos(CleanCursorPos, True)
7125 else
7126 CursorNode := nil;
7127
7128 if CursorNode = nil then begin
7129 // raise exception
7130 CursorNode := FindDeepestNodeAtPos(CleanCursorPos, True);
7131 end;
7132 if CursorNode.Desc = ctnBeginBlock then begin
7133 BuildSubTreeForBeginBlock(CursorNode);
7134 CursorNode := FindDeepestNodeAtPos(CursorNode, CleanCursorPos, True);
7135 end;
7136 // set cursor on identifier
7137 MoveCursorToCleanPos(CleanCursorPos);
7138 GetIdentStartEndAtPosition(Src,CleanCursorPos,
7139 CurPos.StartPos,CurPos.EndPos);
7140 if CurPos.StartPos >= CurPos.EndPos then Exit;
7141 Identifier := @Src[CurPos.StartPos];
7142 // find declaration of identifier
7143 Params := TFindDeclarationParams.Create;
7144 try
7145 Params.ContextNode := CursorNode;
7146 Params.SetIdentifier(Self, Identifier, nil);
7147 Params.Flags := [fdfSearchInParentNodes, fdfTopLvlResolving,
7148 fdfSearchInAncestors, fdfSkipClassForward,
7149 fdfExtractOperand];
7150 if ResolveProperty then
7151 Include(Params.Flags, fdfPropertyResolving);
7152 if FindDeclarationOfIdentAtParam(Params) then
7153 begin
7154 Operand := Params.ExtractedOperand;
7155 Result := Operand <> '';
7156 end;
7157 finally
7158 Params.Free;
7159 end;
7160 finally
7161 ClearIgnoreErrorAfter;
7162 DeactivateGlobalWriteLock;
7163 end;
7164 end;
7165
TFindDeclarationTool.FindIdentifierInProcContextnull7166 function TFindDeclarationTool.FindIdentifierInProcContext(
7167 ProcContextNode: TCodeTreeNode;
7168 Params: TFindDeclarationParams): TIdentifierFoundResult;
7169 { this function is internally used by FindIdentifierInContext
7170 }
7171 var
7172 NameAtom: TAtomPosition;
7173 begin
7174 {$IFDEF CheckNodeTool}CheckNodeTool(ProcContextNode);{$ENDIF}
7175 Result:=ifrProceedSearch;
7176 // if proc is a method body, search in class
7177 // -> find class name
7178 if ProcContextNode.FirstChild=nil then
7179 exit(ifrProceedSearch);
7180 MoveCursorToNodeStart(ProcContextNode.FirstChild);
7181 ReadNextAtom; // read name
7182 if not AtomIsIdentifier then exit; // ignore operator procs
7183 NameAtom:=CurPos;
7184 ReadNextAtom;
7185 if AtomIsChar('.') then begin
7186 // proc is a method body (not a declaration).
7187 // -> proceed the search normally ...
7188 end else begin
7189 // proc is a proc declaration
7190 if ((fdfCollect in Params.Flags)
7191 or CompareSrcIdentifiers(NameAtom.StartPos,Params.Identifier)) then begin
7192 // proc identifier found
7193 // the parameters will be checked by the caller
7194 {$IFDEF ShowTriedContexts}
7195 DebugLn('[TFindDeclarationTool.FindIdentifierInProcContext] Proc-Identifier found="',GetIdentifier(@Src[NameAtom.StartPos]),'"');
7196 {$ENDIF}
7197 Params.SetResult(Self,ProcContextNode,NameAtom.StartPos);
7198 Result:=ifrSuccess;
7199 end else begin
7200 // proceed the search normally ...
7201 end;
7202 end;
7203 end;
7204
FindIdentifierInClassOfMethodnull7205 function TFindDeclarationTool.FindIdentifierInClassOfMethod(
7206 ProcContextNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean;
7207 { this function is internally used by FindIdentifierInContext
7208 }
7209 var
7210 ClassNameAtom: TAtomPosition;
7211 OldFlags: TFindDeclarationFlags;
7212 IdentFoundResult: TIdentifierFoundResult;
7213 CurClassNode: TCodeTreeNode;
7214 ForExprType: TExpressionType;
7215 begin
7216 {$IFDEF CheckNodeTool}CheckNodeTool(ProcContextNode);{$ENDIF}
7217 Result:=false;
7218 // if proc is a method, search in class
7219 // -> find class name
7220 MoveCursorToNodeStart(ProcContextNode);
7221 ReadNextAtom; // read keyword
7222 if UpAtomIs('CLASS') then
7223 ReadNextAtom;
7224 ReadNextAtom; // read classname
7225 ClassNameAtom:=CurPos;
7226 ReadNextAtom;
7227 if AtomIsChar('.') then begin
7228 // proc is a method
7229 if CompareSrcIdentifiers(ClassNameAtom.StartPos,Params.Identifier) then
7230 begin
7231 // the class itself is searched
7232 // -> proceed the search normally ...
7233 end else begin
7234 // search the identifier in the class first
7235 // search the class in the same unit
7236 CurClassNode:=FindClassOfMethod(ProcContextNode,true,true);
7237 repeat
7238 // search identifier in class
7239 OldFlags := Params.Flags;
7240 Params.Flags:=[fdfSearchInAncestors]
7241 +(fdfGlobalsSameIdent*Params.Flags)
7242 -[fdfExceptionOnNotFound];
7243 Params.ContextNode:=CurClassNode;
7244 {$IFDEF ShowTriedContexts}
7245 DebugLn('[TFindDeclarationTool.FindIdentifierInClassOfMethod] searching identifier in class of method Identifier=',GetIdentifier(Params.Identifier));
7246 {$ENDIF}
7247 if (fdfSearchInHelpers in Params.Flags)
7248 and (CurClassNode.Desc in [ctnClassHelper,ctnRecordHelper])
7249 and (Params.GetHelpers(fdhlkDelphiHelper)<>nil)
7250 then begin
7251 // override current helper for the type and search in that type
7252 ForExprType := Params.GetHelpers(fdhlkDelphiHelper).AddFromHelperNode(CurClassNode, Self, True).ForExprType;
7253 if (ForExprType.Desc = xtContext) and (ForExprType.Context.Node<>nil)
7254 then begin
7255 Params.ContextNode:=ForExprType.Context.Node;
7256 Result:=ForExprType.Context.Tool.FindIdentifierInContext(Params);
7257 end;
7258 end else
7259 Result:=FindIdentifierInContext(Params);
7260 Params.Flags := OldFlags;
7261 if Result and Params.IsFoundProcFinal then exit;
7262 // in a nested class, continue search in enclosing class
7263 repeat
7264 CurClassNode:=CurClassNode.Parent;
7265 until (CurClassNode=nil) or (CurClassNode.Desc in AllClassObjects);
7266 until CurClassNode=nil;
7267 end;
7268 end else begin
7269 // proc is not a method
7270 if (fdfCollect in Params.Flags)
7271 or CompareSrcIdentifiers(ClassNameAtom.StartPos,Params.Identifier) then
7272 begin
7273 // proc identifier found
7274 {$IFDEF ShowTriedContexts}
7275 DebugLn('[TFindDeclarationTool.FindIdentifierInClassOfMethod] Proc Identifier found="',GetIdentifier(Params.Identifier),'"');
7276 {$ENDIF}
7277 Params.SetResult(Self,ProcContextNode,ClassNameAtom.StartPos);
7278 IdentFoundResult:=Params.NewCodeTool.DoOnIdentifierFound(Params,
7279 Params.NewNode);
7280 Result:=IdentFoundResult=ifrSuccess;
7281 exit;
7282 end else begin
7283 // proceed the search normally ...
7284 end;
7285 end;
7286 end;
7287
TFindDeclarationTool.FindIdentifierInContextnull7288 function TFindDeclarationTool.FindIdentifierInContext(
7289 Params: TFindDeclarationParams): boolean;
7290 var
7291 IdentFoundResult: TIdentifierFoundResult;
7292 begin
7293 Result := FindIdentifierInContext(Params, IdentFoundResult{%H-});
7294 end;
7295
FindClassOfMethodnull7296 function TFindDeclarationTool.FindClassOfMethod(ProcNode: TCodeTreeNode;
7297 FindClassContext, ExceptionOnNotFound: boolean): TCodeTreeNode;
7298 var
7299 ClassNameAtom: TAtomPosition;
7300 Node: TCodeTreeNode;
7301 TypeNode: TCodeTreeNode;
7302 NextNameAtom: TAtomPosition;
7303 CurClassName: PChar;
7304 CurClassNode: TCodeTreeNode;
7305
7306 procedure RaiseClassNotFound;
7307 begin
7308 MoveCursorToAtomPos(ClassNameAtom);
7309 RaiseExceptionFmt(20170421200233,'Class %s not found',[GetAtom]);
7310 end;
7311
7312 procedure RaiseNotAClass;
7313 begin
7314 MoveCursorToAtomPos(ClassNameAtom);
7315 RaiseExceptionFmt(20170421200237,'Class expected, but %s found',[GetAtom]);
7316 end;
7317
7318 begin
7319 {$IFDEF CheckNodeTool}CheckNodeTool(ProcNode);{$ENDIF}
7320 {$IFDEF ShowTriedContexts}
7321 DebugLn('[TFindDeclarationTool.FindClassOfMethod] A ');
7322 {$ENDIF}
7323 Result:=nil;
7324 if ProcNode.Desc=ctnProcedureHead then
7325 ProcNode:=ProcNode.Parent;
7326 if (ProcNode.Parent<>nil) and (ProcNode.Parent.Desc in AllClassSections) then begin
7327 CurClassNode:=ProcNode.Parent.Parent;
7328 if FindClassContext then begin
7329 // return the class node
7330 exit(CurClassNode);
7331 end else begin
7332 // return the type identifier node
7333 exit(CurClassNode.Parent);
7334 end;
7335 end;
7336
7337 MoveCursorToNodeStart(ProcNode);
7338 ReadNextAtom; // read keyword
7339 if UpAtomIs('CLASS') then ReadNextAtom;
7340 ReadNextAtom; // read classname
7341 ClassNameAtom:=CurPos;
7342 if CurPos.Flag<>cafWord then begin
7343 if not ExceptionOnNotFound then exit;
7344 RaiseNotAClass;
7345 end;
7346 CurClassName:=@Src[ClassNameAtom.StartPos];
7347 ReadNextAtom;
7348 if CurPos.Flag<>cafPoint then begin
7349 // not a method
7350 if not ExceptionOnNotFound then exit;
7351 RaiseNotAClass;
7352 end;
7353 ReadNextAtom;
7354 NextNameAtom:=CurPos;
7355
7356 //debugln(['TFindDeclarationTool.FindClassOfMethod ClassName="',GetAtom(ClassNameAtom),'"']);
7357
7358 // proc is a method
7359 // -> search the class
7360 Node:=ProcNode;
7361 repeat
7362 if Node.Desc=ctnTypeSection then begin
7363 TypeNode:=Node.LastChild;
7364 while TypeNode<>nil do begin
7365 {$IFDEF ShowTriedIdentifiers}
7366 debugln(['TFindDeclarationTool.FindClassOfMethod ',TypeNode.DescAsString,' ',dbgstr(ExtractNode(TypeNode,[]),1,40)]);
7367 {$ENDIF}
7368 if ((TypeNode.Desc=ctnTypeDefinition)
7369 and (CompareIdentifierPtrs(CurClassName,@Src[TypeNode.StartPos])=0))
7370 or ((TypeNode.Desc=ctnGenericType)
7371 and (TypeNode.FirstChild<>nil)
7372 and (CompareIdentifierPtrs(CurClassName,@Src[TypeNode.FirstChild.StartPos])=0))
7373 then begin
7374 repeat
7375 // type with same name found
7376 //debugln(['TFindDeclarationTool.FindClassOfMethod type found ',ExtractDefinitionName(TypeNode)]);
7377 CurClassNode:=FindTypeNodeOfDefinition(TypeNode);
7378 if (CurClassNode=nil) then begin
7379 if not ExceptionOnNotFound then exit;
7380 RaiseClassNotFound;
7381 end;
7382 if (not (CurClassNode.Desc in AllClassObjects))
7383 or ((ctnsForwardDeclaration and Node.SubDesc)<>0)
7384 then begin
7385 if not ExceptionOnNotFound then exit;
7386 RaiseNotAClass;
7387 end;
7388 //debugln(['TFindDeclarationTool.FindClassOfMethod class found, NextNameAtom=',GetAtom(NextNameAtom)]);
7389 // class found
7390 if NextNameAtom.Flag=cafWord then begin
7391 MoveCursorToAtomPos(NextNameAtom);
7392 ReadNextAtom;
7393 if CurPos.Flag<>cafPoint then begin
7394 if FindClassContext then begin
7395 // return the class node
7396 exit(CurClassNode);
7397 end else begin
7398 // return the type identifier node
7399 exit(TypeNode);
7400 end;
7401 end;
7402 ReadNextAtom;
7403 ClassNameAtom:=NextNameAtom;
7404 NextNameAtom:=CurPos;
7405 CurClassName:=@Src[ClassNameAtom.StartPos];
7406 end else begin
7407 // operator or missing sub identifier
7408 if FindClassContext then begin
7409 // return the class node
7410 exit(CurClassNode);
7411 end else begin
7412 // return the type identifier node
7413 exit(TypeNode);
7414 end;
7415 end;
7416 // search sub class
7417 //debugln(['TFindDeclarationTool.FindClassOfMethod searching sub class "',GetIdentifier(CurClassName),'"']);
7418 Node:=FindClassMember(CurClassNode,CurClassName);
7419 if Node=nil then begin
7420 if not ExceptionOnNotFound then exit;
7421 RaiseClassNotFound;
7422 end;
7423 if not (Node.Desc in [ctnTypeDefinition,ctnGenericType]) then begin
7424 if not ExceptionOnNotFound then exit;
7425 RaiseNotAClass;
7426 end;
7427 TypeNode:=Node;
7428 until false;
7429 end;
7430 TypeNode:=TypeNode.PriorBrother;
7431 end;
7432 end;
7433 // next
7434 if Node.PriorBrother<>nil then
7435 Node:=Node.PriorBrother
7436 else begin
7437 Node:=Node.Parent;
7438 if (Node=nil) or (Node.Desc<>ctnImplementation) then break;
7439 Node:=Node.PriorBrother;
7440 if (Node=nil) or (Node.Desc<>ctnInterface) then break;
7441 Node:=Node.LastChild;
7442 if Node=nil then break;
7443 end;
7444 until false;
7445 if ExceptionOnNotFound then
7446 RaiseClassNotFound;
7447 end;
7448
TFindDeclarationTool.FindClassMembernull7449 function TFindDeclarationTool.FindClassMember(aClassNode: TCodeTreeNode;
7450 Identifier: PChar): TCodeTreeNode;
7451 var
7452 Node: TCodeTreeNode;
7453 CurIdentifier: PChar;
7454 begin
7455 Result:=nil;
7456 if GetIdentLen(Identifier)=0 then exit;
7457 if aClassNode=nil then exit;
7458 Node:=aClassNode.LastChild;
7459 while Node<>nil do begin
7460 if (Node.Desc in AllClassSections)
7461 and (Node.FirstChild<>nil) then begin
7462 Node:=Node.LastChild;
7463 continue;
7464 end
7465 else if Node.Desc in AllSimpleIdentifierDefinitions then begin
7466 if CompareIdentifierPtrs(@Src[Node.StartPos],Identifier)=0 then
7467 exit(Node);
7468 end else if Node.Desc=ctnProperty then begin
7469 CurIdentifier:=GetPropertyNameIdentifier(Node);
7470 if CompareIdentifierPtrs(CurIdentifier,Identifier)=0 then
7471 exit(Node);
7472 end else if Node.Desc=ctnProcedure then begin
7473 CurIdentifier:=GetProcNameIdentifier(Node);
7474 if CompareIdentifierPtrs(CurIdentifier,Identifier)=0 then
7475 exit(Node);
7476 end;
7477 // next
7478 if Node.PriorBrother<>nil then
7479 Node:=Node.PriorBrother
7480 else begin
7481 repeat
7482 Node:=Node.Parent;
7483 if Node=aClassNode then exit;
7484 until Node.PriorBrother<>nil;
7485 Node:=Node.PriorBrother;
7486 end;
7487 end;
7488 end;
7489
TFindDeclarationTool.FindClassMembernull7490 function TFindDeclarationTool.FindClassMember(aClassNode: TCodeTreeNode;
7491 const Identifier: String; SearchInAncestors: boolean): TFindContext;
7492 var
7493 Params: TFindDeclarationParams;
7494 begin
7495 Result.Tool:=Self;
7496 Result.Node:=FindClassMember(aClassNode,PChar(Identifier));
7497 if Result.Node<>nil then exit;
7498 if not SearchInAncestors then begin
7499 Result:=CleanFindContext;
7500 exit;
7501 end;
7502 Params:=TFindDeclarationParams.Create;
7503 try
7504 while Result.Tool.FindAncestorOfClass(aClassNode,Params,True) do begin
7505 Result.Tool:=Params.NewCodeTool;
7506 aClassNode:=Params.NewNode;
7507 Result.Node:=Result.Tool.FindClassMember(aClassNode,PChar(Identifier));
7508 if Result.Node<>nil then exit;
7509 end;
7510 Result:=CleanFindContext;
7511 finally
7512 Params.Free;
7513 end;
7514 end;
7515
TFindDeclarationTool.FindAncestorOfClassnull7516 function TFindDeclarationTool.FindAncestorOfClass(ClassNode: TCodeTreeNode;
7517 Params: TFindDeclarationParams; FindClassContext: boolean): boolean;
7518 var
7519 InheritanceNode: TCodeTreeNode;
7520 begin
7521 {$IFDEF CheckNodeTool}CheckNodeTool(ClassNode);{$ENDIF}
7522 if (ClassNode=nil) or (not (ClassNode.Desc in AllClasses)) then
7523 RaiseException(20170421200240,'[TFindDeclarationTool.FindAncestorOfClass] invalid classnode');
7524 Result:=false;
7525
7526 // ToDo: ppu, dcu
7527
7528 InheritanceNode:=FindInheritanceNode(ClassNode);
7529 if (InheritanceNode<>nil)
7530 and (InheritanceNode.FirstChild<>nil) then begin
7531 Result:=FindAncestorOfClassInheritance(InheritanceNode.FirstChild,
7532 Params,FindClassContext);
7533 end else begin
7534 Result:=FindDefaultAncestorOfClass(ClassNode,Params,FindClassContext);
7535 end;
7536 end;
7537
TFindDeclarationTool.FindAncestorOfClassInheritancenull7538 function TFindDeclarationTool.FindAncestorOfClassInheritance(
7539 IdentifierNode: TCodeTreeNode; ResultParams: TFindDeclarationParams;
7540 FindClassContext: boolean): boolean;
7541 var
7542 InheritanceNode: TCodeTreeNode;
7543 ClassNode: TCodeTreeNode;
7544 SpecializeNode , GenericParamsNode: TCodeTreeNode;
7545 AncestorContext: TFindContext;
7546 AncestorStartPos: LongInt;
7547 ExprType: TExpressionType;
7548 Params: TFindDeclarationParams;
7549
7550 procedure RaiseExpected(const Expected: string);
7551 begin
7552 MoveCursorToCleanPos(AncestorStartPos);
7553 ReadNextAtom;
7554 RaiseExceptionFmt(20170421200243,ctsStrExpectedButAtomFound,[Expected,ExtractNode(IdentifierNode,[])]);
7555 end;
7556
7557 begin
7558 {$IFDEF CheckNodeTool}CheckNodeTool(IdentifierNode);{$ENDIF}
7559 if (IdentifierNode=nil)
7560 or (not (IdentifierNode.Desc in [ctnIdentifier,ctnSpecialize]))
7561 or (IdentifierNode.Parent=nil)
7562 or (IdentifierNode.Parent.Desc<>ctnClassInheritance)
7563 then
7564 RaiseException(20170421200245,'[TFindDeclarationTool.FindAncestorOfClass] '
7565 +' not an inheritance node');
7566 Result:=false;
7567
7568 InheritanceNode:=IdentifierNode.Parent;
7569 ClassNode:=InheritanceNode.Parent;
7570
7571 if IdentifierNode.Desc=ctnSpecialize then begin
7572 if (IdentifierNode.FirstChild=nil) then begin
7573 MoveCursorToCleanPos(IdentifierNode.StartPos);
7574 ReadNextAtom;
7575 if UpAtomIs('SPECIALIZE') then
7576 ReadNextAtom;
7577 RaiseStringExpectedButAtomFound(20170421200248,'class type');
7578 end;
7579 MoveCursorToCleanPos(IdentifierNode.FirstChild.StartPos);
7580 end else
7581 MoveCursorToCleanPos(IdentifierNode.StartPos);
7582 ReadNextAtom;
7583 AtomIsIdentifierE;
7584 AncestorStartPos:=CurPos.StartPos;
7585 ReadNextAtom;
7586
7587 Params:=TFindDeclarationParams.Create(ResultParams);
7588 try
7589 Params.Flags:=fdfDefaultForExpressions;
7590 Params.ContextNode:=IdentifierNode;
7591 if CurPos.Flag=cafPoint then begin
7592 // complex identifier
7593 {$IFDEF ShowTriedContexts}
7594 DebugLn(['[TFindDeclarationTool.FindAncestorOfClass] ',
7595 ' search complex ancestor class = "',ExtractNode(IdentifierNode,[]),'" for class "',ExtractClassName(ClassNode,false),'"']);
7596 {$ENDIF}
7597 if not FindClassContext then
7598 Params.Flags:=Params.Flags+[fdfFindVariable];
7599 ExprType:=FindExpressionTypeOfTerm(IdentifierNode.StartPos,IdentifierNode.EndPos,Params,false);
7600 if ExprType.Desc<>xtContext then
7601 RaiseExpected('type');
7602 AncestorContext:=ExprType.Context
7603 end else begin
7604 // simple identifier
7605 {$IFDEF ShowTriedContexts}
7606 DebugLn('[TFindDeclarationTool.FindAncestorOfClass] ',
7607 ' search ancestor class="',GetIdentifier(@Src[AncestorStartPos]),'" for class "',ExtractClassName(ClassNode,false),'"');
7608 {$ENDIF}
7609 Params.SetIdentifier(Self,@Src[AncestorStartPos],nil);
7610 if not FindIdentifierInContext(Params) then
7611 exit;
7612 AncestorContext.Tool:=Params.NewCodeTool;
7613 AncestorContext.Node:=Params.NewNode;
7614 end;
7615 finally
7616 Params.Free;
7617 end;
7618
7619 if FindClassContext then begin
7620 // search ancestor class context
7621 if (AncestorContext.Node.Desc in [ctnTypeDefinition,ctnGenericType]) then
7622 begin
7623 Params:=TFindDeclarationParams.Create;
7624 if IdentifierNode.Desc=ctnSpecialize then begin
7625 SpecializeNode:=IdentifierNode;
7626 Params.SetGenericParamValues(Self, SpecializeNode);
7627 if (ClassNode <> nil) then begin
7628 GenericParamsNode := nil;
7629 if (ClassNode.Parent <> nil)
7630 and (ClassNode.Parent.Desc = ctnGenericType) then
7631 GenericParamsNode:=ClassNode.Parent.FirstChild.NextBrother;
7632 ResultParams.UpdateGenericParamMapping(Self, SpecializeNode.FirstChild.NextBrother, GenericParamsNode);
7633 end;
7634 end;
7635 try
7636 Params.Flags:=fdfDefaultForExpressions+[fdfFindChildren];
7637 AncestorContext:=AncestorContext.Tool.FindBaseTypeOfNode(Params,AncestorContext.Node);
7638 ResultParams.GenParams:=Params.GenParams;
7639 finally
7640 Params.Free;
7641 end;
7642 end;
7643 // check result
7644 if not (AncestorContext.Node.Desc in AllClasses) then
7645 RaiseExpected('class');
7646 if AncestorContext.Node=ClassNode then begin
7647 MoveCursorToCleanPos(AncestorStartPos);
7648 ReadNextAtom;
7649 RaiseException(20170421200252,'cycle detected');
7650 end;
7651 end else begin
7652 // check if class identifier
7653 if (not (AncestorContext.Node.Desc in [ctnTypeDefinition,ctnGenericType])) then
7654 RaiseExpected('type');
7655 end;
7656
7657 ResultParams.SetResult(AncestorContext);
7658 Result:=true;
7659 end;
7660
FindAncestorsOfClassnull7661 function TFindDeclarationTool.FindAncestorsOfClass(ClassNode: TCodeTreeNode;
7662 var ListOfPFindContext: TFPList;
7663 Params: TFindDeclarationParams; FindClassContext: boolean;
7664 ExceptionOnNotFound: boolean): boolean;
7665 var
7666 Node: TCodeTreeNode;
7667 Context: TFindContext;
7668 InheritanceNode: TCodeTreeNode;
7669 begin
7670 Result:=false;
7671 InheritanceNode:=FindInheritanceNode(ClassNode);
7672 if (InheritanceNode=nil) then
7673 exit(true);
7674 Node:=InheritanceNode.FirstChild;
7675 if Node=nil then begin
7676 try
7677 if not FindAncestorOfClass(ClassNode,Params,FindClassContext) then begin
7678 exit(true); // this is TObject or IInterface, IUnknown
7679 end else begin
7680 Context:=CreateFindContext(Params);
7681 end;
7682 AddFindContext(ListOfPFindContext,Context);
7683 Result:=Context.Node<>nil;
7684 except
7685 if ExceptionOnNotFound then raise;
7686 end;
7687 end else begin
7688 while Node<>nil do begin
7689 try
7690 if FindAncestorOfClassInheritance(Node,Params,FindClassContext) then
7691 begin
7692 Context:=CreateFindContext(Params);
7693 AddFindContext(ListOfPFindContext,Context);
7694 end;
7695 except
7696 if ExceptionOnNotFound then raise;
7697 end;
7698 Node:=Node.NextBrother;
7699 end;
7700 end;
7701 Result:=true;
7702 end;
7703
FindForwardIdentifiernull7704 function TFindDeclarationTool.FindForwardIdentifier(
7705 Params: TFindDeclarationParams; out IsForward: boolean): boolean;
7706 { first search the identifier in the normal way via FindIdentifierInContext
7707 then search the other direction }
7708 var
7709 OldInput: TFindDeclarationInput;
7710 begin
7711 Params.Save(OldInput);
7712 Exclude(Params.Flags,fdfExceptionOnNotFound);
7713 Result:=FindIdentifierInContext(Params);
7714 if not Result then begin
7715 Params.Load(OldInput,false);
7716 Params.Flags:=Params.Flags+[fdfSearchForward,fdfIgnoreCurContextNode];
7717 Result:=FindIdentifierInContext(Params);
7718 IsForward:=true;
7719 end else begin
7720 IsForward:=false;
7721 end;
7722 Params.Load(OldInput,true);
7723 end;
7724
FindNonForwardClassnull7725 function TFindDeclarationTool.FindNonForwardClass(ForwardNode: TCodeTreeNode
7726 ): TCodeTreeNode;
7727 var
7728 Node: TCodeTreeNode;
7729 Identifier: PChar;
7730 begin
7731 Result:=nil;
7732 Node:=ForwardNode;
7733 if Node.Desc=ctnGenericType then begin
7734 Node:=Node.FirstChild;
7735 if Node=nil then exit;
7736 end else if Node.Desc<>ctnTypeDefinition then
7737 exit;
7738 Node:=Node.FirstChild;
7739 if Node=nil then
7740 Exit;
7741 Identifier:=@Src[Node.StartPos];
7742 if (Node=nil)
7743 or (not (Node.Desc in AllClasses))
7744 or ((ctnsForwardDeclaration and Node.SubDesc)=0) then
7745 exit;
7746 Node:=ForwardNode;
7747 repeat
7748 //DebugLn(['TFindDeclarationTool.FindNonForwardClass Node=',dbgstr(copy(Src,Node.StartPos,20))]);
7749 if Node.NextBrother<>nil then
7750 Node:=Node.NextBrother
7751 else if (Node.Parent=nil)
7752 or (not (Node.Parent.Desc in AllDefinitionSections)) then
7753 break
7754 else begin
7755 Node:=Node.Parent.NextBrother;
7756 while (Node<>nil)
7757 and ((Node.FirstChild=nil) or (not (Node.Desc in AllDefinitionSections)))
7758 do
7759 Node:=Node.NextBrother;
7760 if Node=nil then break;
7761 Node:=Node.FirstChild;
7762 end;
7763 if CompareSrcIdentifiers(Node.StartPos,Identifier) then begin
7764 Result:=Node;
7765 exit;
7766 end;
7767 until false;
7768 end;
7769
FindNonForwardClassnull7770 function TFindDeclarationTool.FindNonForwardClass(Params: TFindDeclarationParams
7771 ): boolean;
7772 var
7773 Node: TCodeTreeNode;
7774 begin
7775 Node:=FindNonForwardClass(Params.NewNode);
7776 if Node<>nil then begin
7777 Params.SetResult(Self,Node,Node.StartPos);
7778 Result:=true;
7779 end else begin
7780 Result:=false;
7781 end;
7782 end;
7783
FindIdentifierInWithVarContextnull7784 function TFindDeclarationTool.FindIdentifierInWithVarContext(
7785 WithVarNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean;
7786 { this function is internally used by FindIdentifierInContext }
7787 var
7788 WithVarExpr: TExpressionType;
7789 OldInput: TFindDeclarationInput;
7790 OldExtractedOperand, NewExtractedOperand: string;
7791 begin
7792 {$IFDEF ShowExprEval}
7793 DebugLn('[TFindDeclarationTool.FindIdentifierInWithVarContext] Ident=',
7794 '"',GetIdentifier(Params.Identifier),'"',
7795 ' WithStart=',StringToPascalConst(copy(Src,WithVarNode.StartPos,15))
7796 );
7797 {$ENDIF}
7798 {$IFDEF CheckNodeTool}CheckNodeTool(WithVarNode);{$ENDIF}
7799 Result:=false;
7800 // find the base type of the with variable
7801 // move cursor to end of with-variable
7802 Params.Save(OldInput);
7803 Params.ContextNode:=WithVarNode;
7804 Params.Flags:=Params.Flags*fdfGlobals
7805 +[fdfExceptionOnNotFound,fdfFunctionResult,fdfFindChildren];
7806 OldExtractedOperand:=Params.ExtractedOperand;
7807 WithVarExpr:=FindExpressionTypeOfTerm(WithVarNode.StartPos,-1,Params,true);
7808 if fdfExtractOperand in Params.Flags then
7809 NewExtractedOperand:=Params.ExtractedOperand+'.'
7810 else
7811 NewExtractedOperand:='';
7812 if (WithVarExpr.Desc<>xtContext)
7813 or (WithVarExpr.Context.Node=nil)
7814 or (WithVarExpr.Context.Node=OldInput.ContextNode)
7815 or (not (WithVarExpr.Context.Node.Desc in (AllClasses+[ctnEnumerationType])))
7816 then begin
7817 MoveCursorToCleanPos(WithVarNode.StartPos);
7818 RaiseException(20170421200254,ctsExprTypeMustBeClassOrRecord);
7819 end;
7820 // search identifier in 'with' context
7821 // Note: do not search in parent nodes (e.g. with ListBox1 do Items)
7822 Params.Load(OldInput,false);
7823 Params.Flags:=Params.Flags-[fdfExceptionOnNotFound,fdfSearchInParentNodes];
7824 Params.ContextNode:=WithVarExpr.Context.Node;
7825 Result:=WithVarExpr.Context.Tool.FindIdentifierInContext(Params);
7826 Params.Load(OldInput,true);
7827 if fdfExtractOperand in Params.Flags then
7828 if Result then
7829 Params.FExtractedOperand:=NewExtractedOperand
7830 else
7831 Params.FExtractedOperand:=OldExtractedOperand;
7832 end;
7833
TFindDeclarationTool.FindIdentifierInAncestorsnull7834 function TFindDeclarationTool.FindIdentifierInAncestors(
7835 ClassNode: TCodeTreeNode; Params: TFindDeclarationParams;
7836 var IdentFoundResult: TIdentifierFoundResult): boolean;
7837 { this function is internally used by FindIdentifierInContext
7838 and FindBaseTypeOfNode
7839 }
7840
Searchnull7841 function Search(AncestorTool: TFindDeclarationTool;
7842 AncestorClassNode: TCodeTreeNode): boolean;
7843 var
7844 OldFlags: TFindDeclarationFlags;
7845 begin
7846 OldFlags := Params.Flags;
7847 Params.ContextNode:=AncestorClassNode;
7848 Params.Flags:=Params.Flags
7849 -[fdfIgnoreCurContextNode,fdfSearchInParentNodes]
7850 +[fdfSearchInAncestors];
7851 Result:=AncestorTool.FindIdentifierInContext(Params,IdentFoundResult);
7852 Params.Flags := OldFlags;
7853 end;
7854
7855 var
7856 InheritanceNode: TCodeTreeNode;
7857 Node: TCodeTreeNode;
7858 SearchDefaultAncestor: Boolean;
7859 begin
7860 Result:=false;
7861 {$IFDEF CheckNodeTool}CheckNodeTool(ClassNode);{$ENDIF}
7862
7863 if not (fdfSearchInAncestors in Params.Flags) then exit;
7864
7865 SearchDefaultAncestor:=true;
7866 InheritanceNode:=FindInheritanceNode(ClassNode);
7867 if (InheritanceNode<>nil) then begin
7868 Node:=InheritanceNode.FirstChild;
7869 while Node<>nil do begin
7870 if not FindAncestorOfClassInheritance(Node,Params,true) then exit;
7871 SearchDefaultAncestor:=false;
7872 if Search(Params.NewCodeTool,Params.NewNode) then exit(true);
7873 Node:=Node.NextBrother;
7874 end;
7875 end;
7876 //debugln(['TFindDeclarationTool.FindIdentifierInAncestors SearchDefaultAncestor=',SearchDefaultAncestor,' ',CleanPosToStr(ClassNode.StartPos,true)]);
7877 if SearchDefaultAncestor then begin
7878 if not FindDefaultAncestorOfClass(ClassNode,Params,true) then exit;
7879 //debugln(['TFindDeclarationTool.FindIdentifierInAncestors search in default ancestor ',FindContextToString(CreateFindContext(Params.NewCodeTool,Params.NewNode))]);
7880 Result:=Search(Params.NewCodeTool,Params.NewNode);
7881 end;
7882 end;
7883
7884 {$IFDEF DebugPrefix}
7885 procedure TFindDeclarationTool.DecPrefix;
7886 begin
7887 DebugPrefix:=copy(DebugPrefix,1,length(DebugPrefix)-2);
7888 end;
7889
7890 procedure TFindDeclarationTool.IncPrefix;
7891 begin
7892 DebugPrefix:=DebugPrefix+' ';
7893 end;
7894 {$ENDIF}
7895
FindExpressionResultTypenull7896 function TFindDeclarationTool.FindExpressionResultType(
7897 Params: TFindDeclarationParams; StartPos, EndPos: integer;
7898 AliasType: PFindContext): TExpressionType;
7899 {
7900 - operators
7901 - mixing ansistring and shortstring gives ansistring
7902 - Pointer +,- Pointer gives Pointer
7903 - Sets:
7904 [enum1] gives set of enumeration type
7905 set *,-,+ set gives set of same type
7906 set <>,=,<,> set gives boolean
7907 - precedence rules table:
7908 1. brackets
7909 2. not @ sign
7910 3. * / div mod and shl shr as
7911 4. + - or xor
7912 5. < <> > <= >= in is
7913 - nil is compatible to pointers and classes
7914
7915
7916 - operator overloading?
7917 - internal types. e.g. string[], ansistring[], shortstring[], pchar[] to char
7918 - the type of a subrange is the type of the first constant/enum/number/char
7919 - predefined types:
7920 ordinal:
7921 int64, cardinal, QWord, boolean, bytebool, wordbool, qwordbool, longbool, char
7922
7923 real:
7924 real, single, double, extended, cextended, comp, currency
7925
7926 - predefined functions:
7927 function pred(ordinal type): ordinal constant of same type;
7928 function succ(ordinal type): ordinal constant of same type;
7929 function ord(ordinal type): ordinal type;
7930 val?
7931 function low(array): type of leftmost index type in the array;
7932 function high(array): type of leftmost index type in the array;
7933 procedure dec(ordinal var);
7934 procedure dec(ordinal var; ordinal type);
7935 procedure dec(pointer var);
7936 procedure dec(pointer var; ordinal type);
7937 procedure inc(ordinal var);
7938 procedure inc(ordinal var; ordinal type);
7939 procedure inc(pointer var);
7940 procedure inc(pointer var; ordinal type);
7941 procedure write(...);
7942 procedure writeln(...);
7943 function SizeOf(type): ordinal constant;
7944 typeinfo?
7945 uniquestring?
7946 procedure include(set type,enum identifier);
7947 procedure exclude(set type,enum identifier);
7948 function objcselector(string): sel;
7949 }
7950 type
7951 TOperandAndOperator = record
7952 Operand: TOperand;
7953 theOperator: TAtomPosition;
7954 OperatorLvl: integer;
7955 end;
7956 POperandAndOperator = ^TOperandAndOperator;
7957 TExprStack = array[0..4] of TOperandAndOperator;
7958 var
7959 CurExprType: TExpressionType;
7960 CurAliasType: PFindContext;
7961 AliasTypeStorage: TFindContext;
7962 ExprStack: TExprStack;
7963 StackPtr: integer;
7964
7965 procedure ExecuteStack(Complete: boolean);
7966 { Executes the operand+operator stack
7967 Examples:
7968 Position Operand Operator
7969 0 AWord *
7970 1 AByte +
7971 Because * has higher predence than + the stack is executed:
7972 AWord*AByte gives an integer. New stack
7973 Position Operand Operator
7974 0 Integer +
7975 }
7976 var
7977 NewOperand: TOperand;
7978 LastPos: TAtomPosition;
7979 begin
7980 if StackPtr<=0 then begin
7981 // only one element -> nothing to do
7982 exit;
7983 end;
7984 LastPos:=CurPos;
7985 {$IFDEF ShowExprEval}
7986 DebugLn('[TFindDeclarationTool.FindExpressionResultType.ExecuteStack] ',
7987 ' StackPtr=',dbgs(StackPtr),
7988 ' Lvl=',dbgs(ExprStack[StackPtr].OperatorLvl),
7989 ' Complete=',dbgs(Complete));
7990 {$ENDIF}
7991 while (StackPtr>0)
7992 and (Complete
7993 or (ExprStack[StackPtr-1].OperatorLvl<=ExprStack[StackPtr].OperatorLvl)) do
7994 begin
7995 // next operand has a higher or equal precedence
7996 // (lower is computed before higher)
7997 // -> calculate last two operands
7998 NewOperand:=CalculateBinaryOperator(ExprStack[StackPtr-1].Operand,
7999 ExprStack[StackPtr].Operand,ExprStack[StackPtr-1].theOperator,
8000 Params);
8001 // put result on stack
8002 ExprStack[StackPtr-1]:=ExprStack[StackPtr];
8003
8004 dec(StackPtr);
8005 ExprStack[StackPtr].Operand:=NewOperand;
8006 end;
8007 MoveCursorToAtomPos(LastPos);
8008 end;
8009
8010 procedure RaiseBinaryOperatorNotFound;
8011 begin
8012 RaiseExceptionFmt(20170421200256,ctsStrExpectedButAtomFound,[ctsBinaryOperator,GetAtom]);
8013 end;
8014
8015 procedure RaiseInternalError;
8016 begin
8017 RaiseException(20170421200300,'[TFindDeclarationTool.FindExpressionResultType]'
8018 +' internal error: unknown precedence lvl for operator '+GetAtom);
8019 end;
8020
8021 procedure RaiseInternalErrorStack;
8022 begin
8023 RaiseException(20170421200303,'[TFindDeclarationTool.FindExpressionResultType]'
8024 +' internal error: stackptr too big ');
8025 end;
8026
8027 var
8028 OldFlags: TFindDeclarationFlags;
8029 StackEntry: POperandAndOperator;
8030 IsEnd, IsBinOpError: Boolean;
8031 begin
8032 {$IFDEF ShowExprEval}
8033 DebugLn(['[TFindDeclarationTool.FindExpressionResultType] Start',
8034 ' Pos=',StartPos,'-',EndPos,
8035 '="',dbgstr(Src,StartPos,EndPos-StartPos),'" Context=',Params.ContextNode.DescAsString,' Alias=',AliasType<>nil]);
8036 {$ENDIF}
8037 Result:=CleanExpressionType;
8038 if (AliasType<>nil) and (AliasType^.Node=nil) then begin
8039 AliasTypeStorage:=CleanFindContext;
8040 CurAliasType:=@AliasTypeStorage;
8041 end else
8042 CurAliasType:=nil;
8043 OldFlags:=Params.Flags;
8044 Exclude(Params.Flags,fdfFindVariable);
8045 // read the expression from left to right and calculate the type
8046 StackPtr:=-1;
8047 MoveCursorToCleanPos(StartPos);
8048 repeat
8049 // read operand
8050 CurExprType:=ReadOperandTypeAtCursor(Params,EndPos,CurAliasType);
8051 {$IFDEF ShowExprEval}
8052 DebugLn(['[TFindDeclarationTool.FindExpressionResultType] Operand: ',
8053 ExprTypeToString(CurExprType),' Alias=',FindContextToString(CurAliasType)]);
8054 {$ENDIF}
8055 // put operand on stack
8056 inc(StackPtr);
8057 if StackPtr>High(ExprStack) then
8058 RaiseInternalErrorStack;
8059 StackEntry:=@ExprStack[StackPtr];
8060 StackEntry^.Operand.Expr:=CurExprType;
8061 if CurAliasType<>nil then
8062 StackEntry^.Operand.AliasType:=CurAliasType^
8063 else
8064 StackEntry^.Operand.AliasType:=CleanFindContext;
8065 StackEntry^.theOperator.StartPos:=-1;
8066 StackEntry^.OperatorLvl:=5;
8067 // read operator
8068 ReadNextAtom;
8069 {$IFDEF ShowExprEval}
8070 DebugLn('[TFindDeclarationTool.FindExpressionResultType] Operator: ',
8071 GetAtom,' CurPos.EndPos=',dbgs(CurPos.EndPos),' EndPos=',dbgs(EndPos));
8072 {$ENDIF}
8073 IsEnd := (CurPos.EndPos>EndPos) or (CurExprType.Desc=xtNone);
8074 if not IsEnd then
8075 IsBinOpError := not WordIsBinaryOperator.DoItCaseInsensitive(Src,CurPos.StartPos,
8076 CurPos.EndPos-CurPos.StartPos)
8077 else
8078 IsBinOpError := False;
8079 // check if expression is completely parsed
8080 if IsEnd or (IsBinOpError and (fdfIgnoreOperatorError in Params.Flags)) then
8081 begin
8082 // -> execute complete stack
8083 ExecuteStack(true);
8084 Result:=ExprStack[StackPtr].Operand.Expr;
8085 if CurAliasType<>nil then
8086 AliasType^:=ExprStack[StackPtr].Operand.AliasType;
8087 Params.Flags:=OldFlags;
8088 exit;
8089 end;
8090 if IsBinOpError then
8091 RaiseBinaryOperatorNotFound;
8092 // put operator on stack
8093 ExprStack[StackPtr].theOperator:=CurPos;
8094 // find operator precendence level
8095 if WordIsLvl1Operator.DoItCaseInsensitive(Src,CurPos.StartPos,
8096 CurPos.EndPos-CurPos.StartPos)
8097 then
8098 ExprStack[StackPtr].OperatorLvl:=1
8099 else if WordIsLvl2Operator.DoItCaseInsensitive(Src,CurPos.StartPos,
8100 CurPos.EndPos-CurPos.StartPos)
8101 then
8102 ExprStack[StackPtr].OperatorLvl:=2
8103 else if WordIsLvl3Operator.DoItCaseInsensitive(Src,CurPos.StartPos,
8104 CurPos.EndPos-CurPos.StartPos)
8105 then
8106 ExprStack[StackPtr].OperatorLvl:=3
8107 else if WordIsLvl4Operator.DoItCaseInsensitive(Src,CurPos.StartPos,
8108 CurPos.EndPos-CurPos.StartPos)
8109 then
8110 ExprStack[StackPtr].OperatorLvl:=4
8111 else
8112 RaiseInternalError;
8113 // execute stack if possible
8114 ExecuteStack(false);
8115 // move cursor to next atom (= next operand start)
8116 ReadNextAtom;
8117 until false;
8118 end;
8119
TFindDeclarationTool.FindIdentifierInUsesSectionnull8120 function TFindDeclarationTool.FindIdentifierInUsesSection(
8121 UsesNode: TCodeTreeNode; Params: TFindDeclarationParams;
8122 FindMissingFPCUnits: Boolean): boolean;
8123 { this function is internally used by FindIdentifierInContext
8124
8125 search backwards through the uses section
8126 compare first all unit names, then load the units and search there
8127 }
8128 var
8129 NewCodeTool: TFindDeclarationTool;
8130 OldFlags: TFindDeclarationFlags;
8131 Node: TCodeTreeNode;
8132 CollectResult: TIdentifierFoundResult;
8133 MissingUnit: TCodeTreeNode;
8134
8135 procedure RaiseUnitNotFound;
8136 var
8137 AnUnitName: String;
8138 InFilename: String;
8139 begin
8140 AnUnitName:=ExtractUsedUnitName(MissingUnit,@InFilename);
8141 RaiseExceptionInstance(
8142 ECodeToolUnitNotFound.Create(Self,20170421200312,
8143 Format(ctsUnitNotFound,[AnUnitName]),InFilename));
8144 end;
8145
8146 var
8147 AnUnitName: string;
8148 InFilename: string;
8149 begin
8150 {$IFDEF CheckNodeTool}CheckNodeTool(UsesNode);{$ENDIF}
8151 {$IFDEF ShowTriedParentContexts}
8152 DebugLn(['TFindDeclarationTool.FindIdentifierInUsesSection ',MainFilename,' fdfIgnoreUsedUnits=',fdfIgnoreUsedUnits in Params.Flags]);
8153 {$ENDIF}
8154 Result:=false;
8155 // first search the identifier in the uses section (not in the interfaces of the units)
8156 if (Params.IdentifierTool=Self) then begin
8157 Node:=UsesNode.LastChild;
8158 while Node<>nil do begin
8159 if (fdfCollect in Params.Flags) then begin
8160 CollectResult:=DoOnIdentifierFound(Params,Node.FirstChild);
8161 if CollectResult=ifrAbortSearch then begin
8162 Result:=false;
8163 exit;
8164 end else if CollectResult=ifrSuccess then begin
8165 Result:=true;
8166 Params.SetResult(Self,Node.FirstChild);
8167 exit;
8168 end;
8169 end else if CompareSrcIdentifiers(Node.StartPos,Params.Identifier) then begin
8170 // the searched identifier was a uses AUnitName, point to the identifier in
8171 // the uses section
8172 // if the unit name has a namespace defined point to the namespace
8173 Params.SetResult(Self,Node.FirstChild);
8174 Result:=true;
8175 exit;
8176 end;
8177 Node:=Node.PriorBrother;
8178 end;
8179 end;
8180
8181 if not (fdfIgnoreUsedUnits in Params.Flags) then begin
8182 MissingUnit:=nil;
8183 // search in units
8184 Node:=UsesNode.LastChild;
8185 while Node<>nil do begin
8186 AnUnitName:=ExtractUsedUnitName(Node,@InFilename);
8187 if AnUnitName<>'' then begin
8188 NewCodeTool:=FindCodeToolForUsedUnit(AnUnitName,InFilename,false);
8189 if NewCodeTool<>nil then begin
8190 // search the identifier in the interface of the used unit
8191 OldFlags:=Params.Flags;
8192 Params.Flags:=[fdfIgnoreUsedUnits]+(fdfGlobalsSameIdent*Params.Flags)
8193 -[fdfExceptionOnNotFound];
8194 Result:=NewCodeTool.FindIdentifierInInterface(Self,Params);
8195 Params.Flags:=OldFlags;
8196 if Result and Params.IsFoundProcFinal then exit;
8197 end else if MissingUnit=nil then begin
8198 MissingUnit:=Node;
8199 end;
8200 {$IFDEF ShowTriedParentContexts}
8201 DebugLn(['TFindDeclarationTool.FindIdentifierInUsesSection ',AnUnitName,' Result=',Result]);
8202 {$ENDIF}
8203 end;
8204 Node:=Node.PriorBrother;
8205 end;
8206
8207 if (not Result) and (MissingUnit<>nil) then begin
8208 // identifier not found and there is a missing unit
8209 if FindMissingFPCUnits and Assigned(FOnRescanFPCDirectoryCache) then
8210 begin
8211 AnUnitName := LowerCase(AnUnitName);
8212 if FFindMissingFPCUnits=nil then
8213 FFindMissingFPCUnits := TFindIdentifierInUsesSection_FindMissingFPCUnit.Create;
8214 if not FFindMissingFPCUnits.IsInResults(AnUnitName) // don't rescan twice
8215 and FFindMissingFPCUnits.Find(AnUnitName, DirectoryCache) then
8216 begin
8217 FOnRescanFPCDirectoryCache(Self);
8218 Result := FindIdentifierInUsesSection(UsesNode, Params, False);
8219 end else
8220 RaiseUnitNotFound;
8221 end else
8222 RaiseUnitNotFound;
8223 end;
8224 end;
8225 end;
8226
FindCodeToolForUsedUnitnull8227 function TFindDeclarationTool.FindCodeToolForUsedUnit(const AnUnitName,
8228 AnUnitInFilename: string; ExceptionOnNotFound: boolean): TFindDeclarationTool;
8229 var
8230 NewCode: TCodeBuffer;
8231 begin
8232 Result:=nil;
8233 NewCode:=FindUnitSource(AnUnitName,AnUnitInFilename,ExceptionOnNotFound);
8234 if (NewCode=nil) then begin
8235 // no source found
8236 if ExceptionOnNotFound then
8237 RaiseException(20170421200315,'unit '+AnUnitName+' not found');
8238 end else begin
8239 // source found -> get codetool for it
8240 {$IF defined(ShowTriedFiles) or defined(ShowTriedUnits)}
8241 DebugLn('[TFindDeclarationTool.FindCodeToolForUsedUnit] ',
8242 ' This source is=',TCodeBuffer(Scanner.MainCode).Filename,
8243 ' NewCode=',NewCode.Filename);
8244 {$ENDIF}
8245 if Assigned(FOnGetCodeToolForBuffer) then
8246 Result:=FOnGetCodeToolForBuffer(Self,NewCode,false)
8247 else if NewCode=TCodeBuffer(Scanner.MainCode) then
8248 Result:=Self;
8249 end;
8250 end;
8251
FindIdentifierInInterfacenull8252 function TFindDeclarationTool.FindIdentifierInInterface(
8253 AskingTool: TFindDeclarationTool; Params: TFindDeclarationParams): boolean;
8254
8255 function CheckEntry(Entry: PInterfaceIdentCacheEntry): TIdentifierFoundResult;
8256 begin
8257 while Entry<>nil do begin
8258 Params.SetResult(Self,Entry^.Node,Entry^.CleanPos);
8259 Result:=DoOnIdentifierFound(Params,Params.NewNode);
8260 if Result in [ifrSuccess,ifrAbortSearch] then
8261 exit;
8262 // proceed
8263 Entry:=Entry^.Overloaded;
8264 end;
8265 Result:=ifrProceedSearch;
8266 end;
8267
8268 var
8269 CacheEntry: PInterfaceIdentCacheEntry;
8270 AVLNode: TAVLTreeNode;
8271 begin
8272 Result:=false;
8273 // build code tree
8274 {$IFDEF ShowTriedContexts}
8275 DebugLn({$IFDEF DebugPrefix}DebugPrefix,{$ENDIF}
8276 'TFindDeclarationTool.FindIdentifierInInterface',
8277 ' Ident="',GetIdentifier(Params.Identifier),'"',
8278 ' IgnoreUsedUnits=',dbgs(fdfIgnoreUsedUnits in Params.Flags),
8279 ' Self=',TCodeBuffer(Scanner.MainCode).Filename
8280 );
8281 {$ENDIF}
8282
8283 // ToDo: build codetree for ppu, dcu files
8284
8285 // build tree for pascal source
8286 if not BuildInterfaceIdentifierCache(true) then exit(false);
8287 if (AskingTool<>Self) and (AskingTool<>nil) then
8288 AskingTool.AddToolDependency(Self);
8289 // search identifier in cache
8290 if fdfCollect in Params.Flags then begin
8291 AVLNode:=FInterfaceIdentifierCache.Items.FindLowest;
8292 while AVLNode<>nil do begin
8293 CacheEntry:=PInterfaceIdentCacheEntry(AVLNode.Data);
8294 //DebugLn(['TFindDeclarationTool.FindIdentifierInInterface ',CacheEntry^.Identifier]);
8295 case CheckEntry(CacheEntry) of
8296 ifrSuccess: exit(true);
8297 ifrAbortSearch: exit(false);
8298 end;
8299 AVLNode:=FInterfaceIdentifierCache.Items.FindSuccessor(AVLNode);
8300 end;
8301 end else begin
8302 CacheEntry:=FInterfaceIdentifierCache.FindIdentifier(Params.Identifier);
8303 if CacheEntry=nil then
8304 exit(false);
8305 case CheckEntry(CacheEntry) of
8306 ifrSuccess: exit(true);
8307 ifrAbortSearch: exit(false);
8308 end;
8309 end;
8310
8311 // proceed search
8312 Result:=false;
8313 end;
8314
BuildInterfaceIdentifierCachenull8315 function TFindDeclarationTool.BuildInterfaceIdentifierCache(
8316 ExceptionOnNotUnit: boolean): boolean;
8317
8318 procedure ScanForEnums(ParentNode: TCodeTreeNode);
8319 var
8320 Node: TCodeTreeNode;
8321 begin
8322 Node:=ParentNode.FirstChild;
8323 if (Node=nil) or (Scanner.GetDirectiveValueAt(sdScopedEnums, Node.StartPos) = '1') then
8324 Exit;
8325 while Node<>nil do begin
8326 if Node.Desc=ctnEnumIdentifier then
8327 FInterfaceIdentifierCache.Add(@Src[Node.StartPos],Node,Node.StartPos);
8328 if Node.FirstChild<>nil then
8329 Node:=Node.FirstChild
8330 else begin
8331 while Node.NextBrother=nil do begin
8332 Node:=Node.Parent;
8333 if Node=ParentNode then exit;
8334 end;
8335 Node:=Node.NextBrother;
8336 end;
8337 end;
8338 end;
8339
8340 procedure ScanChildren(ParentNode: TCodeTreeNode); forward;
8341
8342 procedure ScanNode(Node: TCodeTreeNode);
8343 var
8344 FirstChild: TCodeTreeNode;
8345 begin
8346 case Node.Desc of
8347 ctnTypeSection,ctnConstSection,ctnVarSection,ctnResStrSection,ctnPropertySection:
8348 ScanChildren(Node);
8349 ctnVarDefinition,ctnConstDefinition,ctnTypeDefinition,ctnGlobalProperty:
8350 begin
8351 FInterfaceIdentifierCache.Add(@Src[Node.StartPos],Node,Node.StartPos);
8352 ScanForEnums(Node);
8353 FirstChild:=Node.FirstChild;
8354 if (Node.Desc = ctnTypeDefinition) and (FirstChild<>nil) then begin
8355 case FirstChild.Desc of
8356 ctnClassHelper, ctnRecordHelper, ctnTypeHelper:
8357 FInterfaceHelperCache[fdhlkDelphiHelper].AddFromHelperNode(FirstChild, Self,
8358 True{ use last found helper}
8359 );
8360 ctnObjCCategory:
8361 FInterfaceHelperCache[fdhlkObjCCategory].AddFromHelperNode(FirstChild, Self, false);
8362 end;
8363 end;
8364 end;
8365 ctnGenericType:
8366 if Node.FirstChild<>nil then begin
8367 FInterfaceIdentifierCache.Add(@Src[Node.FirstChild.StartPos],Node,Node.StartPos);
8368 ScanForEnums(Node);
8369 end;
8370 ctnProperty:
8371 begin
8372 MoveCursorToPropName(Node);
8373 FInterfaceIdentifierCache.Add(@Src[CurPos.StartPos],Node,Node.StartPos);
8374 end;
8375 ctnProcedure:
8376 if (Node.FirstChild<>nil) and (not NodeIsOperator(Node)) then
8377 FInterfaceIdentifierCache.Add(@Src[Node.FirstChild.StartPos],Node,
8378 Node.FirstChild.StartPos);
8379 end;
8380 end;
8381
8382 procedure ScanChildren(ParentNode: TCodeTreeNode);
8383 var
8384 Node: TCodeTreeNode;
8385 begin
8386 Node:=ParentNode.FirstChild;
8387 while Node<>nil do begin
8388 ScanNode(Node);
8389 Node:=Node.NextBrother;
8390 end;
8391 end;
8392
8393 var
8394 InterfaceNode: TCodeTreeNode;
8395 Node: TCodeTreeNode;
8396 HelperKind: TFDHelpersListKind;
8397 begin
8398 // build tree for pascal source
8399 //debugln(['TFindDeclarationTool.BuildInterfaceIdentifierCache BEFORE ',MainFilename]);
8400 BuildTree(lsrImplementationStart);
8401 //debugln(['TFindDeclarationTool.BuildInterfaceIdentifierCache AFTER ',MainFilename]);
8402 if Tree.Root=nil then exit(false);
8403
8404 // search interface section
8405 InterfaceNode:=FindInterfaceNode;
8406 if InterfaceNode=nil then begin
8407 // check source type
8408 if ExceptionOnNotUnit then begin
8409 MoveCursorToNodeStart(Tree.Root);
8410 ReadNextAtom; // read keyword for source type, e.g. 'unit'
8411 if not UpAtomIs('UNIT') then
8412 RaiseException(20170421200317,ctsSourceIsNotUnit);
8413 RaiseException(20170421200319,ctsInterfaceSectionNotFound);
8414 end;
8415 end;
8416
8417 // create tree
8418 if (FInterfaceIdentifierCache<>nil) and FInterfaceIdentifierCache.Complete then
8419 exit(true);
8420
8421 if FInterfaceIdentifierCache=nil then
8422 FInterfaceIdentifierCache:=TInterfaceIdentifierCache.Create(Self)
8423 else
8424 FInterfaceIdentifierCache.Clear;
8425 FInterfaceIdentifierCache.Complete:=true;
8426 for HelperKind in TFDHelpersListKind do
8427 if FInterfaceHelperCache[HelperKind]=nil then
8428 FInterfaceHelperCache[HelperKind]:=TFDHelpersList.Create(HelperKind)
8429 else
8430 FInterfaceHelperCache[HelperKind].Clear;
8431
8432 // add unit node
8433 MoveCursorToNodeStart(Tree.Root);
8434 ReadNextAtom; // keyword unit
8435 ReadNextAtom;
8436 FInterfaceIdentifierCache.Add(@Src[CurPos.StartPos],Tree.Root,CurPos.StartPos);
8437
8438 // create nodes
8439 if InterfaceNode<>nil then
8440 // scan interface
8441 ScanChildren(InterfaceNode)
8442 else begin
8443 // scan program
8444 Node:=Tree.Root;
8445 while Node<>nil do begin
8446 ScanNode(Node);
8447 Node:=Node.NextBrother;
8448 end;
8449 end;
8450
8451 //DebugLn(['TFindDeclarationTool.BuildInterfaceIdentifierCache ',MainFilename,' ',FInterfaceIdentifierCache.Items.Count,' ',GlobalIdentifierTree.Count]);
8452 Result:=true;
8453 end;
8454
CompareNodeIdentifiernull8455 function TFindDeclarationTool.CompareNodeIdentifier(Node: TCodeTreeNode;
8456 Params: TFindDeclarationParams): boolean;
8457 begin
8458 {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF}
8459 Result:=false;
8460 if Node=nil then exit;
8461 if Node.Desc in AllSourceTypes then begin
8462 MoveCursorToNodeStart(Node);
8463 ReadNextAtom;
8464 if (Node.Desc=ctnProgram) and not UpAtomIs('PROGRAM') then exit;
8465 ReadNextAtom;
8466 Result:=CompareSrcIdentifiers(CurPos.StartPos,Params.Identifier);
8467 end else if (Node.Desc in AllSimpleIdentifierDefinitions)
8468 or (Node.Desc in [ctnIdentifier,ctnGenericName]) then begin
8469 Result:=CompareSrcIdentifiers(Node.StartPos,Params.Identifier);
8470 end else if Node.Desc=ctnGenericType then begin
8471 if Node.FirstChild<>nil then
8472 Result:=CompareSrcIdentifiers(Node.FirstChild.StartPos,Params.Identifier);
8473 end;
8474 end;
8475
GetInterfaceNodenull8476 function TFindDeclarationTool.GetInterfaceNode: TCodeTreeNode;
8477 begin
8478 Result:=Tree.Root;
8479 if Result=nil then begin
8480 CurPos.StartPos:=-1;
8481 RaiseException(20170421200323,'[TFindDeclarationTool.GetInterfaceNode] no code tree found');
8482 end;
8483 if not (Tree.Root.Desc in AllUsableSourceTypes) then begin
8484 CurPos.StartPos:=-1;
8485 RaiseException(20170421200325,ctsUsedUnitIsNotAPascalUnit);
8486 end;
8487 Result:=FindInterfaceNode;
8488 if Result=nil then begin
8489 CurPos.StartPos:=-1;
8490 RaiseException(20170421200327,ctsInterfaceSectionNotFound);
8491 end;
8492 end;
8493
FindIdentifierInUsedUnitnull8494 function TFindDeclarationTool.FindIdentifierInUsedUnit(
8495 const AnUnitName: string; Params: TFindDeclarationParams; ErrorPos: integer
8496 ): boolean;
8497 { Note: this function is internally used by FindIdentifierInHiddenUsedUnits
8498 for hidden used units, like the system unit or the objpas unit
8499 }
8500 var
8501 NewCode: TCodeBuffer;
8502 NewCodeTool: TFindDeclarationTool;
8503 OldFlags: TFindDeclarationFlags;
8504 begin
8505 Result:=false;
8506 // open the unit and search the identifier in the interface
8507 NewCode:=FindUnitSource(AnUnitName,'',true,ErrorPos);
8508 if NewCode=TCodeBuffer(Scanner.MainCode) then begin
8509 // Searching again in hidden unit
8510 DebugLn('WARNING: Searching again in hidden unit: "',NewCode.Filename,'" identifier=',GetIdentifier(Params.Identifier));
8511 NewCodeTool:=Self;
8512 MoveCursorToCleanPos(ErrorPos);
8513 RaiseExceptionFmt(20170421200330,ctsIllegalCircleInUsedUnits,[AnUnitName]);
8514 end else begin
8515 // source found -> get codetool for it
8516 {$IF defined(ShowTriedContexts) or defined(ShowTriedUnits)}
8517 DebugLn('[TFindDeclarationTool.FindIdentifierInUsedUnit] ',
8518 ' This source is=',TCodeBuffer(Scanner.MainCode).Filename,
8519 ' NewCode=',NewCode.Filename,' IgnoreUsedUnits=',dbgs(fdfIgnoreUsedUnits in Params.Flags));
8520 {$ENDIF}
8521 NewCodeTool:=nil;
8522 if not Assigned(FOnGetCodeToolForBuffer) then begin
8523 MoveCursorToCleanPos(ErrorPos);
8524 RaiseExceptionFmt(20170421200333,
8525 'Unable to create codetool for "%s", need OnGetCodeToolForBuffer',
8526 [NewCode.Filename]);
8527 end;
8528 NewCodeTool:=FOnGetCodeToolForBuffer(Self,NewCode,false);
8529 if NewCodeTool=nil then begin
8530 MoveCursorToCleanPos(ErrorPos);
8531 RaiseExceptionFmt(20170421200346,'Unable to create codetool for "%s"',[NewCode.Filename]);
8532 end;
8533 // search the identifier in the interface of the used unit
8534 OldFlags:=Params.Flags;
8535 Params.Flags:=[fdfIgnoreUsedUnits]+(fdfGlobalsSameIdent*Params.Flags)
8536 -[fdfExceptionOnNotFound];
8537 Result:=NewCodeTool.FindIdentifierInInterface(Self,Params);
8538 Params.Flags:=OldFlags;
8539 end;
8540 end;
8541
FindIdentifierInTypeOfConstantnull8542 function TFindDeclarationTool.FindIdentifierInTypeOfConstant(
8543 VarConstNode: TCodeTreeNode; Params: TFindDeclarationParams): boolean;
8544 { const a: atype = context;
8545 for example: const p: TPoint = (x:0; y:0);
8546 }
8547 var
8548 TypeNode: TCodeTreeNode;
8549 ExprType: TExpressionType;
8550 TypeParams: TFindDeclarationParams;
8551 OldInput: TFindDeclarationInput;
8552 begin
8553 Result:=false;
8554 //debugln(['TFindDeclarationTool.FindIdentifierInTypeOfConstant ',VarConstNode.DescAsString]);
8555 TypeNode:=VarConstNode.FirstChild;
8556 if TypeNode=nil then exit;
8557 if TypeNode.Desc=ctnIdentifier then begin
8558 // resolve type
8559 //debugln(['TFindDeclarationTool.FindIdentifierInTypeOfConstant ']);
8560 TypeParams:=TFindDeclarationParams.Create(Params);
8561 try
8562 TypeParams.ContextNode:=TypeNode;
8563 TypeParams.SetIdentifier(Self,nil,nil);
8564 TypeParams.Flags:=fdfDefaultForExpressions;
8565 ExprType:=FindExpressionTypeOfTerm(TypeNode.StartPos,-1,TypeParams,false);
8566 //debugln(['TFindDeclarationTool.FindIdentifierInTypeOfConstant ExprType=',ExprTypeToString(ExprType)]);
8567 finally
8568 TypeParams.Free;
8569 end;
8570 if ExprType.Desc=xtContext then begin
8571 if ExprType.Context.Node.Parent=nil then exit;
8572 if not (ExprType.Context.Node.Parent.Desc in [ctnTypeDefinition,ctnGenericType])
8573 then
8574 exit;
8575 // search identifier in type
8576 Params.Save(OldInput);
8577 Params.ContextNode:=ExprType.Context.Node;
8578 Params.Flags:=Params.Flags-[fdfIgnoreCurContextNode,fdfSearchInParentNodes];
8579 Result:=ExprType.Context.Tool.FindIdentifierInContext(Params);
8580 Params.Load(OldInput,true);
8581 end;
8582 end;
8583 end;
8584
8585 procedure TFindDeclarationTool.RaiseUsesExpected(id: int64);
8586 begin
8587 RaiseExceptionFmt(id,ctsStrExpectedButAtomFound,['"uses"',GetAtom]);
8588 end;
8589
8590 procedure TFindDeclarationTool.RaiseStrConstExpected(id: int64);
8591 begin
8592 RaiseExceptionFmt(id,ctsStrExpectedButAtomFound,[ctsStringConstant,GetAtom]);
8593 end;
8594
8595 procedure TFindDeclarationTool.BeginParsing(Range: TLinkScannerRange);
8596 begin
8597 // scan code and init parser
8598 inherited BeginParsing(Range);
8599
8600 // now the scanner knows, which compiler mode is needed
8601 // -> setup compiler dependent tables
8602 case Scanner.PascalCompiler of
8603 pcDelphi: WordIsPredefinedIdentifier:=WordIsPredefinedDelphiIdentifier;
8604 pcPas2js: WordIsPredefinedIdentifier:=WordIsPredefinedPas2jsIdentifier;
8605 else
8606 WordIsPredefinedIdentifier:=WordIsPredefinedFPCIdentifier;
8607 end;
8608 end;
8609
FindIdentifierInHiddenUsedUnitsnull8610 function TFindDeclarationTool.FindIdentifierInHiddenUsedUnits(
8611 Params: TFindDeclarationParams): boolean;
8612 var
8613 HiddenUnits: String;
8614 p: Integer;
8615 AnUnitName: String;
8616 begin
8617 Result:=false;
8618 {$IFDEF ShowTriedContexts}
8619 DebugLn('[TFindDeclarationTool.FindIdentifierInHiddenUsedUnits] ',
8620 '"',GetIdentifier(Params.Identifier),'" IgnoreUsedUnits=',dbgs(fdfIgnoreUsedUnits in Params.Flags));
8621 {$ENDIF}
8622 if (Tree.Root<>nil) and (not (fdfIgnoreUsedUnits in Params.Flags)) then begin
8623 HiddenUnits:=Scanner.GetHiddenUsedUnits;
8624 {$IFDEF ShowTriedContexts}
8625 debugln(['TFindDeclarationTool.FindIdentifierInHiddenUsedUnits Identifier=',GetIdentifier(Params.Identifier),' ',Scanner.MainFilename,' SourceName=',Scanner.SourceName,' HiddenUnits=',HiddenUnits]);
8626 {$ENDIF}
8627 p:=length(HiddenUnits);
8628 while p>=1 do begin
8629 while (p>1) and (HiddenUnits[p-1]<>',') do dec(p);
8630 AnUnitName:=GetDottedIdentifier(@HiddenUnits[p]);
8631 if AnUnitName<>'' then begin
8632 // try hidden used unit
8633 Result:=FindIdentifierInUsedUnit(AnUnitName,Params,0);
8634 if Result and Params.IsFoundProcFinal then exit;
8635 end;
8636 dec(p);
8637 end;
8638 end;
8639 end;
8640
FindEndOfTermnull8641 function TFindDeclarationTool.FindEndOfTerm(
8642 StartPos: integer; ExceptionIfNoVariableStart, WithAsOperator: boolean
8643 ): integer;
8644 { ExceptionIfNoVariableStart: if false allow starting in the middle of a term
8645
8646 a variable can have the form:
8647 A
8648 A.B()^.C()[]^^.D
8649 (A).B
8650 inherited A
8651 A as B
8652 }
8653 procedure RaiseIdentNotFound;
8654 begin
8655 RaiseExceptionFmt(20170421200525,ctsIdentExpectedButAtomFound,[GetAtom]);
8656 end;
8657
8658 var
8659 FirstIdentifier: boolean;
8660
8661 procedure StartVar;
8662 begin
8663 ReadNextAtom;
8664 if UpAtomIs('INHERITED') then
8665 ReadNextAtom;
8666 if UpAtomIs('ARRAY') then
8667 begin
8668 ReadNextAtom;
8669 if UpAtomIs('OF') then
8670 ReadNextAtom;
8671 end;
8672 FirstIdentifier:=true;
8673 if not (CurPos.Flag in AllCommonAtomWords) then exit;
8674 AtomIsIdentifierE;
8675 FirstIdentifier:=false;
8676 ReadNextAtom;
8677 end;
8678
8679 begin
8680 MoveCursorToCleanPos(StartPos);
8681 StartVar;
8682 repeat
8683 case CurPos.Flag of
8684 cafRoundBracketOpen:
8685 begin
8686 ReadTilBracketClose(true);
8687 FirstIdentifier:=false;
8688 end;
8689
8690 cafPoint:
8691 begin
8692 if FirstIdentifier and ExceptionIfNoVariableStart then
8693 RaiseIdentNotFound;
8694 ReadNextAtom;
8695 AtomIsIdentifierE;
8696 end;
8697
8698 cafEdgedBracketOpen:
8699 begin
8700 if FirstIdentifier and ExceptionIfNoVariableStart then
8701 RaiseIdentNotFound;
8702 ReadTilBracketClose(true);
8703 end;
8704
8705 else
8706 if AtomIsChar('^') then begin
8707 if FirstIdentifier and ExceptionIfNoVariableStart then
8708 RaiseIdentNotFound;
8709 end else if UpAtomIs('AS') then begin
8710 if not WithAsOperator then
8711 break;
8712 StartVar;
8713 UndoReadNextAtom;
8714 end else
8715 break;
8716 end;
8717 ReadNextAtom;
8718 until false;
8719 if LastAtoms.HasPrior then
8720 UndoReadNextAtom
8721 else
8722 MoveCursorToCleanPos(StartPos);
8723 Result:=CurPos.EndPos;
8724 end;
8725
FindStartOfTermnull8726 function TFindDeclarationTool.FindStartOfTerm(EndPos: integer; InType: boolean
8727 ): integer;
8728 { a variable can be combinations of
8729 1. A.B
8730 2. A().B
8731 3. inherited A
8732 4. A[].
8733 5. A[].B
8734 6. A^.
8735 7. (A).
8736 8. (A as B)
8737 9. (@A)
8738 10. A()[]
8739 11. nothing (e.g. cursor behind semicolon, keyword or closing bracket)
8740 12. 'A'.B (constant.B, type helpers)
8741 }
8742 procedure RaiseIdentNotFound;
8743 begin
8744 RaiseExceptionFmt(20170421200528,ctsIdentExpectedButAtomFound,[GetAtom]);
8745 end;
8746
8747 var CurAtom, NextAtom: TAtomPosition;
8748 NextAtomType, CurAtomType: TVariableAtomType;
8749 StartPos: LongInt;
8750 CurIsValue, NextIsValue: Boolean;
8751 begin
8752 StartPos:=FindStartOfAtom(Src,EndPos);
8753 MoveCursorToCleanPos(StartPos);
8754 NextAtom:=CurPos;
8755 if not IsSpaceChar[Src[StartPos]] then
8756 ReadNextAtom;
8757 NextAtomType:=GetCurrentAtomType;
8758 NextIsValue:=NextAtomType in [vatIdentifier,vatPreDefIdentifier,vatNumber,vatStringConstant];
8759 repeat
8760 ReadPriorAtom;
8761 CurAtom:=CurPos;
8762 CurAtomType:=GetCurrentAtomType;
8763 if CurAtomType=vatNone then begin
8764 Result:=NextAtom.StartPos;
8765 exit;
8766 end;
8767 //DebugLn(['TFindDeclarationTool.FindStartOfTerm ',GetAtom,' Cur=',VariableAtomTypeNames[CurAtomType],' Next=',VariableAtomTypeNames[NextAtomType]]);
8768 if CurAtomType in [vatRoundBracketClose,vatEdgedBracketClose] then begin
8769 if NextAtomType in [vatRoundBracketOpen,vatRoundBracketClose,
8770 vatEdgedBracketOpen,vatEdgedBracketClose,vatPoint,vatUp,
8771 vatAS,vatNone,vatSpace]
8772 then begin
8773 ReadBackTilBracketOpen(true);
8774 CurAtom.StartPos:=CurPos.StartPos;
8775 end else begin
8776 Result:=NextAtom.StartPos;
8777 exit;
8778 end;
8779 end;
8780 // check if CurAtom belongs to variable
8781 if CurAtomType=vatINHERITED then begin
8782 Result:=CurAtom.StartPos;
8783 exit;
8784 end;
8785 if (CurAtomType in [vatAS,vatKeyword]) then begin
8786 Result:=NextAtom.StartPos;
8787 exit;
8788 end;
8789 if (CurAtomType=vatUp) and InType then begin
8790 Result:=NextAtom.StartPos;
8791 exit;
8792 end;
8793 CurIsValue:=CurAtomType in [vatIdentifier,vatPreDefIdentifier,vatNumber,vatStringConstant];
8794
8795 if (not (CurAtomType in [vatIdentifier,vatPreDefIdentifier,vatNumber,vatStringConstant,
8796 vatPoint,vatUp,vatEdgedBracketClose,vatRoundBracketClose]))
8797 or (CurIsValue and NextIsValue)
8798 then begin
8799 // boundary found between current and next
8800 if NextAtom.StartPos>=EndPos then begin
8801 // no token belongs to a variable (e.g. ; ;)
8802 Result:=EndPos;
8803 end else begin
8804 // the next atom is the start of the variable
8805 if (not (NextAtomType in [vatSpace,vatIdentifier,vatPreDefIdentifier,
8806 vatRoundBracketClose,vatEdgedBracketClose,vatAddrOp])) then
8807 begin
8808 MoveCursorToCleanPos(NextAtom.StartPos);
8809 ReadNextAtom;
8810 RaiseIdentNotFound;
8811 end;
8812 Result:=NextAtom.StartPos;
8813 end;
8814 exit;
8815 end;
8816 NextAtom:=CurAtom;
8817 NextAtomType:=CurAtomType;
8818 NextIsValue:=CurIsValue;
8819 until false;
8820 end;
8821
NodeTermInTypenull8822 function TFindDeclarationTool.NodeTermInType(Node: TCodeTreeNode): boolean;
8823 begin
8824 if Node=nil then exit(false);
8825 Result:=not (Node.Desc in AllPascalStatements);
8826 end;
8827
FindExpressionTypeOfTermnull8828 function TFindDeclarationTool.FindExpressionTypeOfTerm(StartPos,
8829 EndPos: integer; Params: TFindDeclarationParams; WithAsOperator: boolean;
8830 AliasType: PFindContext): TExpressionType;
8831 { examples
8832 1. A.B
8833 2. A().B
8834 3. inherited A
8835 4. A[]
8836 5. A[].B
8837 6. A^.
8838 7. (A).
8839 8. (A as B)
8840 9. (@A)
8841 10. A as B
8842 }
8843 type
8844 TIsIdentEndOfVar = (iieovYes, iieovNo, iieovUnknown);
8845 var
8846 CurAtomType: TVariableAtomType;
8847 NextAtomType: TVariableAtomType; // next, if CurAtomType is brackets then after the brackets
8848 PrevAtomType: TVariableAtomType; // previous, start of brackets
8849 CurAtom, NextAtom: TAtomPosition;
8850 CurAtomBracketEndPos: integer;
8851 StartNode: TCodeTreeNode;
8852 OldInput: TFindDeclarationInput;
8853 StartFlags: TFindDeclarationFlags;
8854 IsIdentEndOfVar: TIsIdentEndOfVar;
8855 FlagCanBeForwardDefined, FlagCanBeForwardDefinedValid: boolean;
8856 ExprType: TExpressionType;
8857 FirstParamStartPos: Integer;
8858 FirstParamProcContext: TFindContext;
8859
8860 procedure RaiseIdentExpected;
8861 begin
8862 RaiseExceptionFmt(20170421200530,ctsStrExpectedButAtomFound,[ctsIdentifier,GetAtom]);
8863 end;
8864
8865 procedure RaiseIdentNotFound;
8866 begin
8867 RaiseExceptionFmt(20170421200532,ctsIdentifierNotFound,[GetAtom]);
8868 end;
8869
8870 procedure RaiseIllegalQualifierFound;
8871 begin
8872 RaiseExceptionFmt(20170421200535,ctsIllegalQualifier,[GetAtom]);
8873 end;
8874
8875 procedure RaisePointNotFound;
8876 begin
8877 RaiseExceptionFmt(20170421200537,ctsStrExpectedButAtomFound,['.',GetAtom]);
8878 end;
8879
8880 procedure RaiseClassDeclarationNotFound(Tool: TFindDeclarationTool);
8881 begin
8882 Tool.RaiseExceptionFmt(20170421200539,ctsClassSNotFound, [Tool.GetAtom]);
8883 end;
8884
8885 function InitAtomQueue: boolean;
8886
8887 procedure RaiseInternalError;
8888 begin
8889 RaiseException(20170421200543,'internal codetool error: FindExpressionTypeOfVariable '
8890 +' StartPos='+IntToStr(StartPos)+' EndPos='+IntToStr(EndPos));
8891 end;
8892
8893 begin
8894 Result:=false;
8895 if StartPos<1 then
8896 StartPos:=FindStartOfTerm(EndPos,NodeTermInType(Params.ContextNode))
8897 else if EndPos<1 then
8898 EndPos:=FindEndOfTerm(StartPos,true,WithAsOperator);
8899 //DebugLn(['InitAtomQueue StartPos=',StartPos,'=',dbgstr(copy(Src,StartPos,10)),' EndPos=',dbgstr(copy(Src,EndPos,10))]);
8900 if (StartPos<1) then
8901 RaiseInternalError;
8902 if StartPos>SrcLen then exit;
8903 if StartPos=EndPos then begin
8904 // e.g. cursor behind semicolon, keyword or closing bracket
8905 exit;
8906 end;
8907 {$IFDEF ShowExprEval}
8908 DebugLn([' FindExpressionTypeOfTerm InitAtomQueue StartPos=',StartPos,' EndPos=',EndPos,' Expr="',copy(Src,StartPos,EndPos-StartPos),'"']);
8909 {$ENDIF}
8910 PrevAtomType:=vatNone;
8911 MoveCursorToCleanPos(StartPos);
8912 ReadNextAtom;
8913 if CurPos.StartPos>SrcLen then exit;
8914 CurAtom:=CurPos;
8915 CurAtomType:=GetCurrentAtomType;
8916 if CurAtomType in [vatRoundBracketOpen,vatEdgedBracketOpen] then
8917 ReadTilBracketClose(true);
8918 CurAtomBracketEndPos:=CurPos.EndPos;
8919 ReadNextAtom;
8920 NextAtom:=CurPos;
8921 if NextAtom.EndPos<=EndPos then
8922 NextAtomType:=GetCurrentAtomType
8923 else
8924 NextAtomType:=vatSpace;
8925 MoveCursorToCleanPos(CurAtom.StartPos);
8926 IsIdentEndOfVar:=iieovUnknown;
8927 FlagCanBeForwardDefinedValid:=false;
8928 Result:=true;
8929 end;
8930
8931 procedure ReadNextExpressionAtom;
8932 begin
8933 PrevAtomType:=CurAtomType;
8934 CurAtom:=NextAtom;
8935 CurAtomType:=NextAtomType;
8936 MoveCursorToCleanPos(NextAtom.StartPos);
8937 ReadNextAtom;
8938 if CurAtomType in [vatRoundBracketOpen,vatEdgedBracketOpen] then
8939 ReadTilBracketClose(true);
8940 CurAtomBracketEndPos:=CurPos.EndPos;
8941 ReadNextAtom;
8942 NextAtom:=CurPos;
8943 if NextAtom.EndPos<=EndPos then
8944 NextAtomType:=GetCurrentAtomType
8945 else
8946 NextAtomType:=vatSpace;
8947 MoveCursorToCleanPos(CurAtom.StartPos);
8948 IsIdentEndOfVar:=iieovUnknown;
8949 end;
8950
8951 function IsIdentifierEndOfVariable: boolean;
8952 var BehindFuncAtomType: TVariableAtomType;
8953 begin
8954 if IsIdentEndOfVar=iieovUnknown then begin
8955 if CurAtom.StartPos>=EndPos then begin
8956 IsIdentEndOfVar:=iieovYes;
8957 end else if CurAtom.Flag=cafWord then begin
8958 ReadNextAtom;
8959 if AtomIsChar('(') then begin
8960 ReadTilBracketClose(true);
8961 ReadNextAtom;
8962 end;
8963 if CurPos.StartPos<EndPos then begin
8964 BehindFuncAtomType:=GetCurrentAtomType;
8965 if (BehindFuncAtomType in [vatPoint,vatUP,
8966 vatEdgedBracketOpen,vatRoundBracketOpen])
8967 then
8968 IsIdentEndOfVar:=iieovNo
8969 else
8970 IsIdentEndOfVar:=iieovYes;
8971 end else begin
8972 IsIdentEndOfVar:=iieovYes;
8973 end;
8974 end else begin
8975 IsIdentEndOfVar:=iieovNo
8976 end;
8977 end;
8978 Result:=(IsIdentEndOfVar=iieovYes);
8979 end;
8980
8981 function CanBeForwardDefined: boolean;
8982 var
8983 Node: TCodeTreeNode;
8984 begin
8985 if not FlagCanBeForwardDefinedValid then begin
8986 FlagCanBeForwardDefinedValid:=true;
8987 FlagCanBeForwardDefined:=false;
8988 Node:=StartNode;
8989 while Node<>nil do begin
8990 if Node.Desc in [ctnTypeDefinition,ctnGenericType] then begin
8991 FlagCanBeForwardDefined:=true;
8992 break;
8993 end else if not (Node.Desc in AllPascalTypes) then
8994 break;
8995 Node:=Node.Parent;
8996 end;
8997 end;
8998 Result:=FlagCanBeForwardDefined;
8999 end;
9000
9001 procedure ResolveTypeLessProperty;
9002 begin
9003 if ExprType.Desc<>xtContext then exit;
9004 with ExprType.Context do begin
9005 if not (Node.Desc in [ctnProperty,ctnGlobalProperty]) then exit;
9006 if Tool.PropNodeIsTypeLess(Node)
9007 and Tool.MoveCursorToPropName(Node) then begin
9008 // typeless property => search in ancestors: it can be property with parameters
9009 Params.Save(OldInput);
9010 Params.SetIdentifier(Tool,@Tool.Src[Tool.CurPos.StartPos],nil);
9011 Params.Flags:=[fdfSearchInAncestors,fdfSearchInHelpers];
9012 if Tool.FindIdentifierInAncestors(Node.Parent.Parent,Params) then begin
9013 Tool:=Params.NewCodeTool;
9014 Node:=Params.NewNode;
9015 end;
9016 Params.Load(OldInput,true);
9017 end;
9018 end;
9019 end;
9020
9021 procedure ResolveStringFunctionParam;
9022 var
9023 FirstParamAlias: TFindContext;
9024 FirstParamExprType: TExpressionType;
9025 begin
9026 MoveCursorToCleanPos(FirstParamStartPos);
9027 ReadNextAtom;
9028 if (CurPos.Flag=cafRoundBracketOpen) then
9029 begin
9030 ReadNextAtom;
9031 FirstParamStartPos := CurPos.StartPos;
9032
9033 if CurPos.Flag<>cafRoundBracketClose then
9034 begin
9035 // read first expressions
9036 // read til comma or bracket close
9037 repeat
9038 while not(AtomIsChar(',') or AtomIsChar('[') or AtomIsChar('(') or AtomIsChar(')')) do
9039 ReadNextAtom;
9040 if CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen] then begin
9041 ReadTilBracketClose(true);
9042 ReadNextAtom;
9043 end;
9044 if (CurPos.StartPos>SrcLen)
9045 or (CurPos.Flag in [cafRoundBracketClose,cafEdgedBracketClose,cafComma])
9046 then
9047 break;
9048 until false;
9049
9050 // find expression type
9051 Params.Flags:=Params.Flags-[fdfExceptionOnNotFound];
9052 FillChar(FirstParamAlias{%H-}, SizeOf(FirstParamAlias), 0);
9053 //DebugLn('TFindDeclarationTool.CreateParamExprListFromStatement CurIgnoreErrorAfterPos=',dbgs(CurIgnoreErrorAfterPos),' ExprStartPos=',dbgs(ExprStartPos));
9054 FirstParamExprType:=FindExpressionResultType(Params,FirstParamStartPos,CurPos.StartPos,@FirstParamAlias);
9055 if (FirstParamExprType.Desc in [xtAnsiString, xtString, xtShortString]) then
9056 begin
9057 ExprType := FirstParamExprType;
9058 if AliasType<>nil then
9059 AliasType^ := FirstParamAlias;
9060 end;
9061 end;
9062 end;
9063 end;
9064
9065 procedure ResolveBaseTypeOfIdentifier;
9066 { normally not the identifier is searched, but its type
9067 but there is one exception:
9068 if the identifier is a function and it is the end of the variable then
9069 the decision is based on the fdfFunctionResult flag.
9070 }
9071 var
9072 ProcNode, FuncResultNode, FirstParamNode: TCodeTreeNode;
9073 AtEnd: Boolean;
9074 CurAliasType: PFindContext;
9075 Context: TFindContext;
9076 FirstParamProcExpr: TExpressionType;
9077 NewParams: TFindDeclarationParams;
9078 begin
9079 //DebugLn(['ResolveBaseTypeOfIdentifier ',ExprType.Context.Node<>nil]);
9080 if ExprType.Desc=xtContext then
9081 Context:=ExprType.Context
9082 else
9083 Context:=CreateFindContext(Self,StartNode);
9084 if (Context.Node=nil) then exit;
9085
9086 AtEnd:=IsIdentifierEndOfVariable;
9087 // check if at the end of the variable
9088 if AtEnd and (fdfFindVariable in StartFlags) then begin
9089 // the variable is wanted, not its type
9090 exit;
9091 end;
9092 if (not AtEnd)
9093 and (Context.Node.Desc in [ctnProperty,ctnGlobalProperty])
9094 then begin
9095 ResolveTypeLessProperty;
9096 end;
9097
9098 CurAliasType:=nil;
9099 if AtEnd then CurAliasType:=AliasType;
9100
9101 // find base type
9102 Params.Flags:=Params.Flags+[fdfEnumIdentifier]-[fdfFunctionResult,fdfFindChildren];
9103 {$IFDEF ShowExprEval}
9104 DebugLn([' FindExpressionTypeOfTerm ResolveBaseTypeOfIdentifier BEFORE ExprType=',ExprTypeToString(ExprType),' Alias=',CurAliasType<>nil]);
9105 {$ENDIF}
9106 ExprType:=Context.Tool.ConvertNodeToExpressionType(
9107 Context.Node,Params,CurAliasType);
9108 {$IFDEF ShowExprEval}
9109 DebugLn([' FindExpressionTypeOfTerm ResolveBaseTypeOfIdentifier AFTER ExprType=',ExprTypeToString(ExprType),' Alias=',FindContextToString(CurAliasType)]);
9110 {$ENDIF}
9111 if (ExprType.Desc=xtContext)
9112 and (ExprType.Context.Node.Desc in [ctnProcedure,ctnProcedureHead]) then
9113 begin
9114 // check if this is a function
9115 ProcNode:=ExprType.Context.Node;
9116 if ProcNode.Desc=ctnProcedureHead then
9117 ProcNode:=ProcNode.Parent;
9118 ExprType.Context.Tool.BuildSubTreeForProcHead(ProcNode.FirstChild,
9119 FuncResultNode);
9120 {$IFDEF ShowExprEval}
9121 DebugLn([' FindExpressionTypeOfTerm ResolveBaseTypeOfIdentifier IsFunction=',FuncResultNode<>nil,' IsIdentifierEndOfVariable=',IsIdentifierEndOfVariable,' fdfFunctionResult in StartFlags=',fdfFunctionResult in StartFlags]);
9122 {$ENDIF}
9123 if (FuncResultNode<>nil) then begin
9124 // it is function
9125 // -> use the result type instead of the function
9126 if AtEnd then begin
9127 // this function identifier is the end of the variable
9128 if not (fdfFunctionResult in StartFlags) then
9129 exit;
9130 end;
9131 Include(Params.Flags,fdfFunctionResult);
9132 ExprType:=ExprType.Context.Tool.ConvertNodeToExpressionType(
9133 ProcNode,Params,CurAliasType);
9134
9135 if (ExprType.Desc in [xtAnsiString, xtString, xtShortString])
9136 and (FirstParamStartPos>0)
9137 and (FirstParamProcContext.Node<>nil) then
9138 begin
9139 FirstParamNode := FirstParamProcContext.Node;
9140 while (FirstParamNode<>nil) and (FirstParamNode.Desc in [ctnProcedure, ctnProcedureHead, ctnParameterList]) do
9141 FirstParamNode := FirstParamNode.FirstChild;
9142 if (FirstParamNode<>nil) and (FirstParamNode.Desc=ctnVarDefinition) then
9143 begin
9144 while FirstParamNode.NextBrother<>nil do
9145 FirstParamNode := FirstParamNode.NextBrother;
9146 FirstParamNode := FirstParamNode.FirstChild;
9147 end;
9148 if (FirstParamNode<>nil) and (FirstParamNode.Desc=ctnIdentifier) then
9149 begin
9150 NewParams := TFindDeclarationParams.Create(FirstParamProcContext.Tool, FirstParamProcContext.Node);
9151 try
9152 FirstParamProcExpr := FirstParamProcContext.Tool.FindExpressionResultType(NewParams, FirstParamNode.StartPos, FirstParamNode.EndPos);
9153 finally
9154 NewParams.Free;
9155 end;
9156 if FirstParamProcExpr.Desc in [xtAnsiString, xtString, xtShortString] then
9157 ResolveStringFunctionParam;
9158 end;
9159 end;
9160 end;
9161 end;
9162 end;
9163
9164 function ResolveUseUnit(StartUseUnitNode: TCodeTreeNode): TCodeTreeNode;
9165 // IsStart=true, NextAtomType=vatPoint,
9166 // StartUseUnitNameNode.Desc=ctnUseUnit
9167 // -> Find the longest namespaced used unit (ctnUseUnitNamespace,ctnUseUnitClearName)
9168 // or the source name (ctnIdentifier), that fits the start of the
9169 // current identifier a.b.c...
9170 //
9171
9172 function GetPrevUseUnit(UseUnitNode: TCodeTreeNode): TCodeTreeNode;
9173 begin
9174 if UseUnitNode.PriorBrother<>nil then
9175 Result:=UseUnitNode.PriorBrother
9176 else begin
9177 if UseUnitNode.Parent.Parent.Desc=ctnImplementation then begin
9178 Result:=FindMainUsesNode;
9179 if Result<>nil then
9180 Result:=Result.FirstChild;
9181 end else
9182 Result:=nil;
9183 end;
9184 end;
9185
9186 var
9187 UseUnitNode, Node, BestNode: TCodeTreeNode;
9188 HasNamespace: Boolean;
9189 Count, Level, BestLevel: Integer;
9190 p: PChar;
9191 DottedIdentifier: String;
9192 begin
9193 Result:=StartUseUnitNode.FirstChild;
9194 //debugln(['ResolveUsenit START ',NextAtomType,' ',StartUseUnitNode.DescAsString,' "',GetIdentifier(@Src[CurAtom.StartPos]),'"']);
9195 // find all candidates
9196 Count:=0;
9197 HasNamespace:=false;
9198 UseUnitNode:=StartUseUnitNode;
9199 repeat
9200 if (UseUnitNode.FirstChild<>nil)
9201 and CompareSrcIdentifiers(CurAtom.StartPos,UseUnitNode.StartPos) then begin
9202 // found candidate
9203 inc(Count);
9204 //debugln(['ResolveUsenit candidate found']);
9205 if UseUnitNode.FirstChild.Desc=ctnUseUnitNamespace then begin
9206 HasNamespace:=true;
9207 end;
9208 end;
9209 UseUnitNode:=GetPrevUseUnit(UseUnitNode);
9210 until UseUnitNode=nil;
9211 //debugln(['ResolveUsenit CandidateCount=',Count,' HasNamespace=',HasNamespace]);
9212 if not HasNamespace then exit;
9213
9214 // multiple uses start with this identifier -> collect candidates
9215 //debugln(['ResolveUsenit collect candidates ...']);
9216
9217 // read a.b.c...
9218 DottedIdentifier:=GetIdentifier(@Src[CurAtom.StartPos]);
9219 MoveCursorToCleanPos(NextAtom.EndPos);
9220 Level:=1;
9221 repeat
9222 ReadNextAtom;
9223 if not AtomIsIdentifier then break;
9224 inc(Level);
9225 DottedIdentifier:=DottedIdentifier+'.'+GetAtom;
9226 ReadNextAtom;
9227 until CurPos.Flag<>cafPoint;
9228 //debugln(['ResolveUsenit DottedIdentifier="',DottedIdentifier,'"']);
9229
9230 // find longest dotted unit name in uses and source name
9231 UseUnitNode:=StartUseUnitNode;
9232 BestNode:=nil;
9233 BestLevel:=0;
9234 repeat
9235 Node:=UseUnitNode.FirstChild; // ctnUseUnitNamespace or ctnUseUnitClearName
9236 UseUnitNode:=GetPrevUseUnit(UseUnitNode);
9237 if (Node<>nil)
9238 and CompareSrcIdentifiers(CurAtom.StartPos,Node.StartPos) then begin
9239 // found candidate
9240 //debugln(['ResolveUseUnit Candidate=',ExtractNode(Node,[])]);
9241 Level:=1;
9242 p:=PChar(DottedIdentifier);
9243 repeat
9244 inc(p,GetIdentLen(p));
9245 if p^='.' then inc(p);
9246 //debugln(['ResolveUseUnit p=',p,' NextBrother=',Node.NextBrother<>nil]);
9247 if Node.NextBrother=nil then begin
9248 // fits
9249 if Level>BestLevel then begin
9250 BestNode:=Node.Parent;
9251 BestLevel:=Level;
9252 end;
9253 break;
9254 end else if p^=#0 then begin
9255 // unitname too long
9256 break;
9257 end else begin
9258 Node:=Node.NextBrother;
9259 //debugln(['ResolveUseUnit p=',p,' node=',GetIdentifier(@Src[Node.StartPos])]);
9260 if not CompareSrcIdentifiers(Node.StartPos,p) then
9261 break;
9262 inc(Level);
9263 end;
9264 until false;
9265 end;
9266 until UseUnitNode=nil;
9267 //debugln(['ResolveUseUnit collected candidates Best=',ExtractNode(BestNode,[])]);
9268
9269 //debugln(['ResolveUseUnit Src=',Tree.Root.DescAsString,' Name=',GetSourceName(false),' DottedIdentifier="',DottedIdentifier,'"']);
9270 // check source name
9271 if (Tree.Root.Desc in AllSourceTypes)
9272 and (Tree.Root.FirstChild<>nil)
9273 and (Tree.Root.FirstChild.Desc=ctnSrcName)
9274 and CompareSrcIdentifiers(Tree.Root.FirstChild.StartPos,PChar(DottedIdentifier))
9275 then begin
9276 // found candidate
9277 Level:=1;
9278 Node:=Tree.Root.FirstChild.FirstChild;
9279 //debugln(['ResolveUseUnit Candidate SrcName']);
9280 p:=PChar(DottedIdentifier);
9281 repeat
9282 //debugln('ResolveUseUnit SrcName p=',p,' Node=',ExtractNode(Node,[]));
9283 if (Node.FirstChild=nil) or (Node.NextBrother.Desc<>ctnIdentifier) then begin
9284 // fits
9285 //debugln(['ResolveUseUnit FITS Level=',Level,' Best=',BestLevel]);
9286 if Level>BestLevel then begin
9287 // source name fits best
9288 Result:=Tree.Root.FirstChild.FirstChild;
9289 // move cursor forward
9290 while (Result.NextBrother<>nil)
9291 and (NextAtom.EndPos<EndPos) do begin
9292 if (Result.NextBrother=nil) then
9293 exit(Tree.Root);
9294 ReadNextExpressionAtom; // read point
9295 ReadNextExpressionAtom; // read namespace/unitname
9296 //debugln(['ResolveUseUnit Next ',GetAtom(CurAtom)]);
9297 Result:=Result.NextBrother;
9298 end;
9299 //debugln(['ResolveUseUnit SrcName fits better']);
9300 exit;
9301 end;
9302 break;
9303 end else if p^=#0 then begin
9304 // source name too long
9305 break;
9306 end else begin
9307 Node:=Node.NextBrother;
9308 inc(p,GetIdentLen(p));
9309 if p^='.' then inc(p);
9310 //debugln('ResolveUseUnit SrcName NEXT p=',p,' Node=',ExtractNode(Node,[]));
9311 if not CompareSrcIdentifiers(Node.StartPos,p) then
9312 break;
9313 inc(Level);
9314 end;
9315 until false;
9316 end;
9317
9318 Result:=BestNode;
9319 if Result=nil then exit;
9320
9321 // Result is now a ctnUseUnit
9322 Result:=Result.FirstChild;
9323 // move cursor forward
9324 while (Result.NextBrother<>nil) and (NextAtom.EndPos<EndPos) do begin
9325 ReadNextExpressionAtom; // read point
9326 ReadNextExpressionAtom; // read namespace/unitname
9327 //debugln(['ResolveUseUnit Next ',GetAtom(CurAtom)]);
9328 Result:=Result.NextBrother;
9329 end;
9330 end;
9331
9332 function ResolveAttribute(const Context: TFindContext): boolean;
9333 var
9334 Identifier: String;
9335 l: Integer;
9336 begin
9337 Result:=false;
9338 if CurAtom.Flag<>cafWord then exit;
9339 Identifier:=GetAtom;
9340 l:=length(Identifier)-length('attribute');
9341 if (l>0) and (CompareIdentifiers(@Identifier[l+1],'attribute')=0) then
9342 exit;
9343 // auto append 'attribute' to typename
9344 Identifier+='Attribute';
9345 Params.SetIdentifier(Self,PChar(Identifier),@CheckSrcIdentifier);
9346 if Context.Tool.FindIdentifierInContext(Params) then begin
9347 ExprType.Desc:=xtContext;
9348 ExprType.Context:=CreateFindContext(Params);
9349 Params.Load(OldInput,true);
9350 exit(true);
9351 end;
9352 Params.Load(OldInput,false);
9353 Result:=false;
9354 end;
9355
9356 procedure ResolveIdentifier;
9357 var
9358 ProcNode: TCodeTreeNode;
9359 IdentFound: boolean;
9360 OldFlags: TFindDeclarationFlags;
9361 ResultNode: TCodeTreeNode;
9362 IsStart: Boolean;
9363 Context: TFindContext;
9364 IsEnd: Boolean;
9365 SearchForwardToo: Boolean;
9366 begin
9367 // for example 'AnObject[3]'
9368
9369 {$IFDEF ShowExprEval}
9370 debugln(['ResolveIdentifier "',GetAtom(CurAtom),'"']);
9371 {$ENDIF}
9372
9373 // check special identifiers 'Result' and 'Self'
9374 IdentFound:=false;
9375 IsStart:=ExprType.Desc=xtNone;
9376 IsEnd:=IsIdentifierEndOfVariable;
9377 if IsStart then begin
9378 // start context
9379 if (StartNode.Desc in AllPascalStatements) then begin
9380 if CompareSrcIdentifiers(CurAtom.StartPos,'SELF') then begin
9381 // SELF in a method is the object itself
9382 // -> check if in a method or nested proc of a method
9383 if fdfExtractOperand in Params.Flags then
9384 Params.AddOperandPart('Self');
9385 ProcNode:=StartNode;
9386 while (ProcNode<>nil) do begin
9387 if (ProcNode.Desc=ctnProcedure) and NodeIsMethodBody(ProcNode) then
9388 begin
9389 ResultNode:=FindClassOfMethod(ProcNode,True,
9390 fdfExceptionOnNotFound in Params.Flags);
9391 if (ResultNode<>nil) and
9392 (ResultNode.Desc in [ctnClassHelper,ctnRecordHelper,ctnTypeHelper])
9393 then//Self is helper -> return extended type
9394 begin
9395 ExprType := FindExtendedExprOfHelper(ResultNode);
9396 ResultNode := ExprType.Context.Node;
9397 end else
9398 begin//Self is class/record
9399 if (ResultNode<>nil) and (ResultNode.Parent<>nil) then
9400 begin
9401 ExprType.Desc:=xtContext;
9402 ExprType.Context.Tool:=Self;
9403 end else
9404 ExprType := CleanExpressionType;
9405 end;
9406 if IsEnd and (ResultNode<>nil) then
9407 ResultNode := ResultNode.Parent;
9408 ExprType.Context.Node:=ResultNode;
9409 IdentFound:=ExprType.Desc<>xtNone;
9410 break;
9411 end;
9412 ProcNode:=ProcNode.Parent;
9413 end;
9414 end else if CompareSrcIdentifiers(CurAtom.StartPos,'RESULT')
9415 and (cmsResult in Scanner.CompilerModeSwitches) then begin
9416 // RESULT has a special meaning in a function
9417 // -> check if in a function
9418 if fdfExtractOperand in Params.Flags then
9419 Params.AddOperandPart('Result');
9420 ProcNode:=StartNode;
9421 while (ProcNode<>nil) do begin
9422 if (ProcNode.Desc=ctnProcedure)
9423 and (NodeIsFunction(ProcNode) or NodeIsOperator(ProcNode)) then
9424 break;
9425 ProcNode:=ProcNode.Parent;
9426 end;
9427 if (ProcNode<>nil) then begin
9428 if IsEnd and (fdfFindVariable in StartFlags) then begin
9429 BuildSubTreeForProcHead(ProcNode);
9430 ResultNode:=ProcNode.FirstChild.FirstChild;
9431 while (ResultNode<>nil) do begin
9432 if ResultNode.Desc in [ctnVarDefinition,ctnIdentifier] then begin
9433 // procedure: none
9434 // operator: ctnVarDefinition,ctnIdentifier
9435 // function: ctnIdentifier
9436 ExprType.Desc:=xtContext;
9437 ExprType.Context.Node:=ResultNode;
9438 ExprType.Context.Tool:=Self;
9439 exit;
9440 end;
9441 ResultNode:=ResultNode.NextBrother;
9442 end;
9443 end else begin
9444 OldFlags:=Params.Flags;
9445 Params.Flags:=Params.Flags+[fdfFunctionResult,fdfFindChildren];
9446 ExprType.Context:=FindBaseTypeOfNode(Params,ProcNode);
9447 ExprType.Desc:=xtContext;
9448 Params.Flags:=OldFlags;
9449 exit;
9450 end;
9451 end;
9452 end;
9453 end;
9454 end;
9455 // find identifier
9456 if not IdentFound then begin
9457 if not (ExprType.Desc in [xtContext,xtNone]) then
9458 begin
9459 // find special sub identifier
9460 if (ExprType.Desc in xtAllTypeHelperTypes) then
9461 begin
9462 // found predefined basic type (e.g. string) without a context!
9463 // -> search in type helpers
9464 Params.Save(OldInput);
9465 // build new param flags for sub identifiers
9466 Params.Flags:=[fdfSearchInAncestors,fdfExceptionOnNotFound,fdfSearchInHelpers]
9467 +(fdfGlobals*Params.Flags);
9468 Params.SetIdentifier(Self,@Src[CurAtom.StartPos],nil);
9469 {$IFDEF ShowExprEval}
9470 debugln(['ResolveIdentifier searching "',GetAtom(CurAtom),'" in helper of predefined type "',ExprTypeToString(ExprType),'"']);
9471 {$ENDIF}
9472 if FindIdentifierInBasicTypeHelpers(ExprType.Desc, Params) then
9473 begin
9474 ExprType.Desc:=xtContext;
9475 ExprType.SubDesc:=xtNone;
9476 ExprType.Context.Tool := Params.NewCodeTool;
9477 ExprType.Context.Node := Params.NewNode;
9478 {$IFDEF ShowExprEval}
9479 debugln(['ResolveIdentifier "',GetAtom(CurAtom),'" Found In Helper: "',ExprTypeToString(ExprType),'"']);
9480 {$ENDIF}
9481 end else begin
9482 {$IFDEF ShowExprEval}
9483 debugln(['ResolveIdentifier "',GetAtom(CurAtom),'" NOT Found In Helper']);
9484 {$ENDIF}
9485 end;
9486 Params.Load(OldInput,true);
9487 end;
9488
9489 if ExprType.Desc in xtAllPredefinedTypes then begin
9490 ExprType:=FindExpressionTypeOfPredefinedIdentifier(CurAtom.StartPos,
9491 Params);
9492 {$IFDEF CheckNodeTool}
9493 if ExprType.Desc=xtContext then
9494 ExprType.Context.Tool.CheckNodeTool(ExprType.Context.Node);
9495 {$ENDIF}
9496 {$IFDEF ShowExprEval}
9497 debugln(['ResolveIdentifier Predefined "',GetAtom(CurAtom),'" : ',ExprType.Desc in xtAllTypeHelperTypes]);
9498 {$ENDIF}
9499 end;
9500 end else
9501 begin
9502 // find identifier
9503 if ExprType.Desc=xtContext then
9504 Context:=ExprType.Context
9505 else
9506 Context:=CreateFindContext(Self,StartNode);
9507 Params.Save(OldInput);
9508 // build new param flags for sub identifiers
9509 Params.Flags:=[fdfSearchInAncestors,fdfExceptionOnNotFound,fdfSearchInHelpers]
9510 +(fdfGlobals*Params.Flags);
9511 Params.ContextNode:=Context.Node;
9512 SearchForwardToo:=false;
9513 if Context.Node=StartNode then begin
9514 // there is no special context -> search in parent contexts too
9515 Params.Flags:=Params.Flags+[fdfSearchInParentNodes,fdfIgnoreCurContextNode];
9516 // check if searching forward too
9517 if CanBeForwardDefined then begin
9518 SearchForwardToo:=true;
9519 Params.Flags:=Params.Flags-[fdfExceptionOnNotFound];
9520 end;
9521 end else begin
9522 // only search in special context
9523 Params.Flags:=Params.Flags+[fdfIgnoreUsedUnits];
9524 if Assigned(Context.Node) and (Context.Node.Desc=ctnImplementation) then
9525 Params.Flags:=Params.Flags+[fdfSearchInParentNodes];
9526 if Context.Node.Desc=ctnObjCClass then
9527 Exclude(Params.Flags,fdfExceptionOnNotFound); // ObjCClass has predefined identifiers like 'alloc'
9528 end;
9529
9530 // check identifier for overloaded procs
9531 if (IsEnd and (fdfIgnoreOverloadedProcs in StartFlags))
9532 then
9533 Include(Params.Flags,fdfIgnoreOverloadedProcs);
9534
9535 //debugln(['ResolveIdentifier ',IsEnd,' ',GetAtom(CurAtom),' ',Context.Node.DescAsString,' ',Context.Node.Parent.DescAsString,' ']);
9536 if IsEnd and (Context.Node.Desc=ctnIdentifier)
9537 and (Context.Node.Parent.Desc=ctnAttribParam)
9538 and ResolveAttribute(Context) then begin
9539 exit;
9540 end;
9541
9542 Params.SetIdentifier(Self,@Src[CurAtom.StartPos],@CheckSrcIdentifier);
9543
9544 // search ...
9545 {$IFDEF ShowExprEval}
9546 Debugln([' FindExpressionTypeOfTerm ResolveIdentifier "',GetIdentifier(Params.Identifier),'" backward ',BoolToStr(IsStart,'Main','Sub'),'Ident="',GetIdentifier(Params.Identifier),'" ContextNode="',Params.ContextNode.DescAsString,'" "',dbgstr(Context.Tool.Src,Params.ContextNode.StartPos,15),'" ',dbgs(Params.Flags)]);
9547 {$ENDIF}
9548 ExprType.Desc:=xtNone;
9549 // first search backwards
9550 if Context.Tool.FindIdentifierInContext(Params) then begin
9551 ExprType.Desc:=xtContext;
9552 end else if SearchForwardToo then begin
9553 // then search forwards
9554 Params.Load(OldInput,false);
9555 Params.SetIdentifier(Self,@Src[CurAtom.StartPos],@CheckSrcIdentifier);
9556 Params.Flags:=[fdfSearchInParentNodes,fdfExceptionOnNotFound,
9557 fdfIgnoreCurContextNode,fdfSearchForward]
9558 +(fdfGlobals*Params.Flags);
9559 Params.ContextNode:=Context.Node;
9560 {$IFDEF ShowExprEval}
9561 DebugLn([' FindExpressionTypeOfTerm ResolveIdentifier "',GetAtom(CurAtom),'" forward SubIdent="',GetIdentifier(Params.Identifier),'" ContextNode="',Params.ContextNode.DescAsString,'" "',dbgstr(Context.Tool.Src,Params.ContextNode.StartPos,15),'" ',dbgs(Params.Flags)]);
9562 {$ENDIF}
9563 if FindIdentifierInContext(Params) then begin
9564 ExprType.Desc:=xtContext;
9565 end;
9566 end;
9567 if ExprType.Desc=xtContext then begin
9568 // identifier found
9569 if Params.NewCodeTool.NodeIsConstructor(Params.NewNode) then begin
9570 // identifier is a constructor
9571 if (Context.Node.Desc in AllClassObjects) then begin
9572 if (not IsEnd) or (not (fdfFindVariable in StartFlags)) then begin
9573 // examples:
9574 // TMyClass.Create.
9575 // :=TMyClass.Create;
9576 // use this class (the constructor can be defined in the ancestor)
9577 ExprType.Context:=Context;
9578 Params.Load(OldInput,true);
9579 exit;
9580 end;
9581 end;
9582 end;
9583 if IsStart and (NextAtomType=vatPoint)
9584 and (Params.NewCodeTool=Self)
9585 and (Params.NewNode.Desc in [ctnUseUnitClearName,ctnUseUnitNamespace])
9586 then begin
9587 // first identifier is a used unit -> find longest fitting unitname
9588 //debugln(['ResolveIdentifier UseUnit FindLongest... ',Params.NewNode.DescAsString,' ',ExtractNode(Params.NewNode,[])]);
9589 Params.NewNode:=ResolveUseUnit(Params.NewNode.Parent);
9590 //debugln(['ResolveIdentifier UseUnit FoundLongest: ',Params.NewNode.DescAsString,' ',ExtractNode(Params.NewNode,[])]);
9591 end;
9592 ExprType.Context:=CreateFindContext(Params);
9593 Params.Load(OldInput,true);
9594 end else begin
9595 // predefined identifier
9596 if (Context.Node.Desc=ctnObjCClass)
9597 and CompareSrcIdentifiers('alloc',@Src[CurAtom.StartPos])
9598 then begin
9599 // 'alloc' returns the class itself
9600 ExprType.Context:=Context;
9601 //debugln(['ResolveIdentifier ',ExprTypeToString(ExprType)]);
9602 Params.Load(OldInput,true);
9603 exit;
9604 end;
9605
9606 Params.Load(OldInput,true);
9607 if IsEnd then
9608 ExprType:=FindExpressionTypeOfPredefinedIdentifier(CurAtom.StartPos,
9609 Params,AliasType)
9610 else
9611 ExprType:=FindExpressionTypeOfPredefinedIdentifier(CurAtom.StartPos,
9612 Params);
9613 {$IFDEF CheckNodeTool}
9614 if ExprType.Desc=xtContext then
9615 ExprType.Context.Tool.CheckNodeTool(ExprType.Context.Node);
9616 {$ENDIF}
9617 end;
9618 end;
9619 {$IFDEF ShowExprEval}
9620 DebugLn([' FindExpressionTypeOfTerm ResolveIdentifier END Ident="',dbgstr(Src,StartPos,CurAtom.EndPos-StartPos),'" Expr=',ExprTypeToString(ExprType)]);
9621 {$ENDIF}
9622 end;
9623 end;
9624
9625 procedure ResolveConstant;
9626 var
9627 IsStart: Boolean;
9628 begin
9629 IsStart:=ExprType.Desc=xtNone;
9630 if not IsStart then
9631 RaiseExceptionFmt(20170421200546,ctsOperatorExpectedButAtomFound,[GetAtom]);
9632 if AtomIsStringConstant then begin
9633 // string or char constant
9634 if AtomIsCharConstant then
9635 ExprType.Desc:=xtChar
9636 else
9637 ExprType.Desc:=xtConstString;
9638 MoveCursorToCleanPos(CurPos.StartPos);
9639 end
9640 else if AtomIsNumber then begin
9641 // ordinal or real constant
9642 if AtomIsRealNumber then
9643 ExprType.Desc:=xtConstReal
9644 else
9645 ExprType.Desc:=xtConstOrdInteger;
9646 MoveCursorToCleanPos(CurPos.EndPos);
9647 end else
9648 RaiseExceptionFmt(20170421200548,ctsOperatorExpectedButAtomFound,[GetAtom]);
9649 end;
9650
9651 procedure ResolveUseUnit;
9652 var
9653 AnUnitName: string;
9654 InFilename: string;
9655 aTool: TFindDeclarationTool;
9656 NewCodeTool: TFindDeclarationTool;
9657 NewNode: TCodeTreeNode;
9658 begin
9659 aTool:=ExprType.Context.Tool;
9660 {$IFDEF ShowExprEval}
9661 debugln([' FindExpressionTypeOfTerm ResolveUseUnit used unit -> interface node ',dbgstr(ExprType.Context.Tool.ExtractNode(ExprType.Context.Node,[]))]);
9662 {$ENDIF}
9663 AnUnitName:=aTool.ExtractUsedUnitName(ExprType.Context.Node.Parent,@InFilename);
9664 NewCodeTool:=aTool.FindCodeToolForUsedUnit(AnUnitName,InFilename,true);
9665 NewCodeTool.BuildInterfaceIdentifierCache(true);
9666 NewNode:=NewCodeTool.FindInterfaceNode;
9667 ExprType.Context.Tool:=NewCodeTool;
9668 ExprType.Context.Node:=NewNode;
9669 end;
9670
9671 procedure ResolveChildren;
9672 var
9673 NewNode: TCodeTreeNode;
9674 begin
9675 if (ExprType.Context.Node=nil) then exit;
9676 {$IFDEF ShowExprEval}
9677 debugln([' FindExpressionTypeOfTerm ResolveChildren']);
9678 {$ENDIF}
9679 ResolveBaseTypeOfIdentifier;
9680 {$IFDEF ShowExprEval}
9681 debugln([' FindExpressionTypeOfTerm ResolveChildren ExprType=',ExprTypeToString(ExprType)]);
9682 //debugln(['ResolveChildren xtContext=',(ExprType.Desc=xtContext),
9683 // ' ctnPointerType=',(ExprType.Context.Node.Desc=ctnPointerType),
9684 // ' Node=',(ExprType.Context.Node<>StartNode),
9685 // ' cmsAutoderef=',(cmsAutoderef in Scanner.CompilerModeSwitches),
9686 // ' ',CompilerModeNames[Scanner.CompilerMode]
9687 // ]);
9688 {$ENDIF}
9689 NewNode:=ExprType.Context.Node;
9690 if (NewNode=nil) then exit;
9691 if (NewNode.Desc in AllUsableSourceTypes)
9692 or (NewNode.Desc=ctnSrcName)
9693 or ((NewNode.Desc=ctnIdentifier) and (NewNode.Parent.Desc=ctnSrcName)
9694 and (NewNode.NextBrother=nil))
9695 then begin
9696 if ExprType.Context.Tool=Self then begin
9697 // unit name of this unit => implementation
9698 // Note: allowed for programs too
9699 NewNode:=Tree.Root;
9700 if NewNode.Desc=ctnUnit then begin
9701 NewNode:=FindImplementationNode;
9702 if NewNode=nil then
9703 NewNode:=FindInterfaceNode;
9704 end;
9705 {$IFDEF ShowExprEval}
9706 debugln([' FindExpressionTypeOfTerm ResolveChildren this unit -> ',NewNode.DescAsString]);
9707 {$ENDIF}
9708 ExprType.Context.Node:=NewNode;
9709 end else begin
9710 // unit name of another unit => interface
9711 {$IFDEF ShowExprEval}
9712 debugln([' FindExpressionTypeOfTerm ResolveChildren unit -> interface node']);
9713 {$ENDIF}
9714 ExprType.Context.Node:=ExprType.Context.Tool.GetInterfaceNode;
9715 end;
9716 end
9717 else if (ExprType.Context.Node.Desc=ctnUseUnitClearName) then begin
9718 // uses unit name => interface of used unit
9719 ResolveUseUnit;
9720 end
9721 else if (ExprType.Context.Node.Desc=ctnClassOfType) then begin
9722 // 'class of' => jump to the class
9723 ExprType.Context:=ExprType.Context.Tool.FindBaseTypeOfNode(Params,ExprType.Context.Node.FirstChild);
9724 end
9725 else if (ExprType.Desc=xtContext)
9726 and (ExprType.Context.Node.Desc=ctnPointerType)
9727 and (ExprType.Context.Node<>StartNode)
9728 and (cmsAutoderef in Scanner.CompilerModeSwitches) then begin
9729 // Delphi knows . as shortcut for ^.
9730 // -> check for pointer type
9731 // left side of expression has defined a special context
9732 // => this '.' is a dereference
9733 ExprType.Context:=ExprType.Context.Tool.FindBaseTypeOfNode(Params,ExprType.Context.Node.FirstChild);
9734 end;
9735 end;
9736
9737 procedure ResolvePoint;
9738 begin
9739 // for example 'A.B'
9740 if fdfExtractOperand in Params.Flags then
9741 Params.AddOperandPart('.');
9742 if (not (NextAtomType in [vatSpace,vatIdentifier,vatPreDefIdentifier])) then
9743 begin
9744 MoveCursorToCleanPos(NextAtom.StartPos);
9745 ReadNextAtom;
9746 RaiseIdentExpected;
9747 end;
9748 ResolveChildren;
9749 if ExprType.Desc in xtAllTypeHelperTypes then begin
9750 // Lazarus supports record helpers for basic types (string) as well (with TYPEHELPERS modeswitch!).
9751 end else if (ExprType.Context.Node=nil) then begin
9752 MoveCursorToCleanPos(CurAtom.StartPos);
9753 ReadNextAtom;
9754 RaiseIllegalQualifierFound;
9755 end else if ExprType.Context.Node.Desc in AllPointContexts then begin
9756 // ok, allowed
9757 end else begin
9758 // not allowed
9759 //debugln(['ResolvePoint ',ExprTypeToString(ExprType)]);
9760 MoveCursorToCleanPos(CurAtom.StartPos);
9761 ReadNextAtom;
9762 RaiseIllegalQualifierFound;
9763 end;
9764 end;
9765
9766 procedure ResolveAs;
9767 begin
9768 // for example 'A as B'
9769 if (not (NextAtomType in [vatSpace,vatIdentifier,vatPreDefIdentifier])) then
9770 begin
9771 MoveCursorToCleanPos(NextAtom.StartPos);
9772 ReadNextAtom;
9773 RaiseIdentExpected;
9774 end;
9775 // 'as' is a type cast, so the left side is irrelevant
9776 // -> context is default context
9777 ExprType.Desc:=xtContext;
9778 ExprType.Context.Tool:=Self;
9779 ExprType.Context.Node:=StartNode;
9780 end;
9781
9782 procedure ResolveUp;
9783 begin
9784 // for example:
9785 // 1. 'PInt = ^integer' pointer type
9786 // 2. a^ dereferencing
9787 {$IFDEF ShowExprEval}
9788 debugln([' FindExpressionTypeOfTerm ResolveUp']);
9789 {$ENDIF}
9790 if fdfExtractOperand in Params.Flags then
9791 Params.AddOperandPart('^');
9792 if (not (NextAtomType in [vatSpace,vatPoint,vatUp,vatAS,vatEdgedBracketOpen]))
9793 or ((ExprType.Context.Node=nil) and (ExprType.Desc<>xtPointer))
9794 then begin
9795 MoveCursorToCleanPos(NextAtom.StartPos);
9796 ReadNextAtom;
9797 RaiseIllegalQualifierFound;
9798 end;
9799 ResolveBaseTypeOfIdentifier;
9800 if (ExprType.Desc=xtPointer) then begin
9801 // the compiler type 'Pointer'
9802 exit;
9803 end;
9804 if (ExprType.Context.Node<>StartNode) then begin
9805 // left side of expression has defined a special context
9806 // => this '^' is a dereference
9807 if (not
9808 (NextAtomType in [vatSpace,vatPoint,vatAS,vatUP,vatEdgedBracketOpen]))
9809 then begin
9810 MoveCursorToCleanPos(NextAtom.StartPos);
9811 ReadNextAtom;
9812 RaisePointNotFound;
9813 end;
9814 if (ExprType.Context.Node=nil)
9815 or (ExprType.Context.Node.Desc<>ctnPointerType) then begin
9816 MoveCursorToCleanPos(CurAtom.StartPos);
9817 RaiseExceptionFmt(20170421200550,ctsIllegalQualifier,['^']);
9818 end;
9819 ExprType.Desc:=xtContext;
9820 ExprType.Context.Node:=ExprType.Context.Node.FirstChild;
9821 end else if NodeHasParentOfType(ExprType.Context.Node,ctnPointerType) then
9822 begin
9823 // this is a pointer type definition
9824 // -> the default context is ok
9825 end;
9826 end;
9827
9828 procedure ResolveEdgedBracketOpen;
9829 { for example: a[]
9830 this could be:
9831 1. ranged array e.g. array[1..2] of
9832 2. dynamic array e.g. array of integer
9833 3. variant array e.g. array of const
9834 4. indexed pointer e.g. PInteger[1]
9835 5. default property e.g. Items[Index: integer]
9836 6. indexed property e.g. Items[Index: integer]
9837 7. string character e.g. string[3]
9838 }
9839
9840 procedure RaiseTypeIdentNotFound;
9841 begin
9842 ExprType.Context.Tool.RaiseExceptionFmt(20170421200553,ctsStrExpectedButAtomFound,
9843 [ctsTypeIdentifier,ExprType.Context.Tool.GetAtom]);
9844 end;
9845
9846 procedure RaiseIdentInCurContextNotFound;
9847 begin
9848 ExprType.Context.Tool.RaiseExceptionFmt(20170421200557,ctsStrExpectedButAtomFound,
9849 [ctsIdentifier,GetAtom]);
9850 end;
9851 begin
9852 {$IFDEF ShowExprEval}
9853 debugln([' FindExpressionTypeOfTerm ResolveEdgedBracketOpen ',ExprTypeToString(ExprType)]);
9854 {$ENDIF}
9855 if fdfExtractOperand in Params.Flags then begin
9856 // simple copying, todo: expand argument
9857 Params.AddOperandPart(ExtractBrackets(CurPos.StartPos,[]));
9858 end;
9859 if (not (NextAtomType in [vatSpace,vatPoint,vatAs,vatUp,vatRoundBracketClose,
9860 vatRoundBracketOpen,vatEdgedBracketClose,vatEdgedBracketOpen]))
9861 then begin
9862 MoveCursorToCleanPos(NextAtom.StartPos);
9863 ReadNextAtom;
9864 RaiseIllegalQualifierFound;
9865 end;
9866
9867 if (ExprType.Desc=xtContext)
9868 and (ExprType.Context.Node.Desc=ctnProperty) then begin
9869 // [] behind a property
9870 // -> Check if this property has parameters
9871 ResolveTypeLessProperty;
9872 if (ExprType.Desc=xtContext)
9873 and (ExprType.Context.Node.Desc=ctnProperty)
9874 and ExprType.Context.Tool.PropertyNodeHasParamList(ExprType.Context.Node)
9875 then begin
9876 // use the property type
9877 ResolveChildren;
9878 exit;
9879 end;
9880 end;
9881
9882 ResolveBaseTypeOfIdentifier;
9883
9884 if ExprType.Desc in xtAllStringTypes then begin
9885 ExprType.Desc:=xtChar;
9886 ExprType.Context.Node:=nil;
9887 exit;
9888 end;
9889 if ExprType.Desc in xtAllWideStringTypes then begin
9890 ExprType.Desc:=xtWideChar;
9891 ExprType.Context.Node:=nil;
9892 exit;
9893 end;
9894 if ExprType.Context.Node=nil then begin
9895 MoveCursorToCleanPos(NextAtom.StartPos);
9896 ReadNextAtom;
9897 RaiseIllegalQualifierFound;
9898 end;
9899
9900 if ExprType.Context.Node.Desc in [ctnRangedArrayType,ctnOpenArrayType] then
9901 begin
9902 MoveCursorToCleanPos(CurAtom.StartPos);
9903 ReadNextAtom; // "["
9904 ReadNextAtom;
9905 repeat
9906 case CurPos.Flag of
9907 cafRoundBracketClose: SaveRaiseBracketCloseExpectedButAtomFound(20170425090717);
9908 cafRoundBracketOpen,
9909 cafEdgedBracketOpen: ReadTilBracketClose(true);
9910 cafComma:
9911 with ExprType, Context do begin
9912 Context:=Tool.FindBaseTypeOfNode(Params,Node.LastChild);
9913 if not (Node.Desc in [ctnRangedArrayType,ctnOpenArrayType]) then
9914 RaiseIllegalQualifierFound;
9915 end;
9916 end;
9917 ReadNextAtom;
9918 until CurPos.Flag=cafEdgedBracketClose;
9919 end;
9920
9921 {$IFDEF ShowExprEval}
9922 DebugLn([' FindExpressionTypeOfTerm ResolveEdgedBracketOpen ExprType=',ExprTypeToString(ExprType)]);
9923 {$ENDIF}
9924 case ExprType.Context.Node.Desc of
9925
9926 ctnOpenArrayType,ctnRangedArrayType:
9927 begin
9928 // the array type is the last child node
9929 //debugln('ResolveEdgedBracketOpen Open/RangedArray LastChild=',ExprType.Context.Node.LastChild.DescAsString);
9930 if ExprType.Context.Node.LastChild.Desc=ctnOfConstType then begin
9931 // 'array of const'; the array type is 'TVarRec'
9932
9933 // => search 'TVarRec'
9934 Params.Save(OldInput);
9935 Params.Flags:=[fdfSearchInParentNodes,fdfIgnoreCurContextNode,
9936 fdfExceptionOnNotFound,fdfFindChildren];
9937 // special identifier for TVarRec
9938 Params.SetIdentifier(Self,'tvarrec',nil);
9939 Params.ContextNode:=ExprType.Context.Node;
9940 ExprType.Context.Tool.FindIdentifierInContext(Params);
9941 ExprType.Context:=CreateFindContext(Params);
9942 Params.Load(OldInput,true);
9943 end else begin
9944 ExprType.Context.Node:=ExprType.Context.Node.LastChild;
9945 end;
9946 end;
9947
9948 ctnPointerType:
9949 // the pointer type is the only child node
9950 ExprType.Context.Node:=ExprType.Context.Node.FirstChild;
9951
9952 ctnClass, ctnClassInterface, ctnDispinterface, ctnObject, ctnRecordType,
9953 ctnClassHelper, ctnRecordHelper, ctnTypeHelper,
9954 ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass:
9955 begin
9956 // search default property of the class / interface
9957 Params.Save(OldInput);
9958 Params.Flags:=[fdfSearchInAncestors,fdfExceptionOnNotFound,fdfSearchInHelpers]
9959 +fdfGlobals*Params.Flags;
9960 // special identifier '[' for default property
9961 Params.SetIdentifier(Self,@Src[CurAtom.StartPos],nil);
9962 Params.ContextNode:=ExprType.Context.Node;
9963 ExprType.Context.Tool.FindIdentifierInContext(Params);
9964 ExprType.Context:=CreateFindContext(Params);
9965 Params.Load(OldInput,true);
9966 end;
9967
9968 ctnProperty, ctnGlobalProperty:
9969 begin
9970 if not ExprType.Context.Tool.PropertyNodeHasParamList(ExprType.Context.Node) then
9971 RaiseIdentInCurContextNotFound;
9972 end;
9973
9974 ctnIdentifier:
9975 begin
9976 MoveCursorToNodeStart(ExprType.Context.Node);
9977 ReadNextAtom;
9978 if UpAtomIs('STRING') or UpAtomIs('ANSISTRING')
9979 or UpAtomIs('SHORTSTRING') then begin
9980 ExprType.Desc:=xtChar;
9981 ExprType.Context.Node:=nil;
9982 exit;
9983 end else if UpAtomIs('WIDESTRING') or UpAtomIs('UNICODESTRING') then begin
9984 ExprType.Desc:=xtWideChar;
9985 ExprType.Context.Node:=nil;
9986 exit;
9987 end else begin
9988 MoveCursorToCleanPos(CurAtom.StartPos);
9989 ReadNextAtom;
9990 RaiseIllegalQualifierFound;
9991 end;
9992 end;
9993
9994 else
9995 MoveCursorToCleanPos(CurAtom.StartPos);
9996 ReadNextAtom;
9997 RaiseIllegalQualifierFound;
9998 end;
9999 end;
10000
10001 procedure ResolveRoundBracketOpen;
10002 begin
10003 { for example:
10004 (a+b) expression bracket: the type is the result type of the
10005 expression.
10006 a() typecast or function
10007 }
10008 if not (NextAtomType in [vatSpace,vatPoint,vatAs,vatUp,vatRoundBracketClose,
10009 vatRoundBracketOpen,vatEdgedBracketClose,vatEdgedBracketOpen]) then
10010 begin
10011 MoveCursorToCleanPos(NextAtom.StartPos);
10012 ReadNextAtom;
10013 RaiseIllegalQualifierFound;
10014 end;
10015 if PrevAtomType<>vatNone then begin
10016 // typecast or function
10017 {$IFDEF ShowExprEval}
10018 debugln([' FindExpressionTypeOfTerm ResolveRoundBracketOpen skip typecast/paramlist="',dbgstr(Src,CurAtom.StartPos,CurAtomBracketEndPos-CurAtom.StartPos),'"']);
10019 {$ENDIF}
10020 if fdfExtractOperand in Params.Flags then begin
10021 if (ExprType.Context.Node<>nil)
10022 and (ExprType.Context.Node.Desc=ctnTypeDefinition) then begin
10023 // typecast
10024 with ExprType.Context do
10025 Params.AddOperandPart(GetIdentifier(@Tool.Src[Node.StartPos]));
10026 Params.AddOperandPart('(');
10027 // assumption: one term in brakets
10028 FindExpressionTypeOfTerm(CurAtom.StartPos+1,CurAtomBracketEndPos-1,
10029 Params,false);
10030 Params.AddOperandPart(')');
10031 end;
10032 end;
10033 if fdfOverrideStringTypesWithFirstParamType in Params.Flags then begin
10034 if (ExprType.Context.Node<>nil)
10035 and (ExprType.Context.Node.Desc in [ctnProcedure, ctnProcedureHead])
10036 and (FirstParamStartPos<0) then begin
10037 FirstParamStartPos := CurAtom.StartPos;
10038 FirstParamProcContext := ExprType.Context;
10039 end;
10040 end;
10041 end else begin
10042 // expression
10043 {$IFDEF ShowExprEval}
10044 debugln([' FindExpressionTypeOfTerm ResolveRoundBracketOpen subexpr="',dbgstr(Src,CurAtom.StartPos,CurAtomBracketEndPos-CurAtom.StartPos),'"']);
10045 {$ENDIF}
10046 ExprType:=FindExpressionResultType(Params,CurAtom.StartPos+1,
10047 CurAtomBracketEndPos-1, AliasType);
10048 end;
10049 end;
10050
10051 procedure ResolveINHERITED;
10052 // for example: inherited A; inherited;
10053 // inherited skips the class and begins to search in the ancestor class
10054 var
10055 ProcNode: TCodeTreeNode;
10056 ClassNodeOfMethod: TCodeTreeNode;
10057 HasIdentifier: Boolean;
10058 Context: TFindContext;
10059 var
10060 DefProcNode: TCodeTreeNode;
10061 HelperForExpr: TExpressionType;
10062 SearchInHelpersInTheEnd: Boolean;
10063 begin
10064 if ExprType.Desc=xtNone then
10065 Context:=CreateFindContext(Self,StartNode)
10066 else
10067 Context:=ExprType.Context;
10068
10069 if (Context.Node<>StartNode) or (Context.Node=nil) then begin
10070 MoveCursorToCleanPos(CurAtom.StartPos);
10071 RaiseIllegalQualifierFound;
10072 end;
10073 ProcNode:=GetMethodOfBody(Context.Node);
10074 if ProcNode=nil then begin
10075 MoveCursorToCleanPos(CurAtom.StartPos);
10076 RaiseException(20170421200601,ctsInheritedKeywordOnlyAllowedInMethods);
10077 end;
10078 HasIdentifier:=NextAtom.EndPos<=EndPos;
10079 if HasIdentifier then begin
10080 if (not (NextAtomType in [vatIdentifier,vatPreDefIdentifier])) then
10081 begin
10082 MoveCursorToCleanPos(NextAtom.StartPos);
10083 ReadNextAtom;
10084 RaiseIdentExpected;
10085 end;
10086
10087 ReadNextExpressionAtom;
10088 end;
10089 {$IFDEF ShowExprEval}
10090 DebugLn(' FindExpressionTypeOfTerm ResolveINHERITED CurAtomType=',
10091 VariableAtomTypeNames[CurAtomType],
10092 ' CurAtom="',copy(Src,CurAtom.StartPos,CurAtom.EndPos-CurAtom.StartPos),'"');
10093 {$ENDIF}
10094
10095 // find class of method
10096 ClassNodeOfMethod:=FindClassOfMethod(ProcNode,true,true);
10097
10098 // find class ancestor
10099 OldInput.Flags:=Params.Flags;
10100 Params.Flags:=[fdfSearchInParentNodes,fdfExceptionOnNotFound]
10101 +fdfGlobals*Params.Flags;
10102 FindAncestorOfClass(ClassNodeOfMethod,Params,true);
10103 Params.Flags:=OldInput.Flags;
10104
10105 ExprType.Desc:=xtContext;
10106 ExprType.Context:=CreateFindContext(Params);
10107
10108 SearchInHelpersInTheEnd := False;
10109 if ClassNodeOfMethod.Desc in [ctnClassHelper,ctnRecordHelper] then
10110 begin
10111 // helpers have different order in "inherited" call.
10112 // -> first search in extended class and then in helper (applies only to inherited call)
10113 if (ExprType.Context.Node<>nil) then//inherited helper found -> use it!
10114 Params.GetHelpers(fdhlkDelphiHelper,true)
10115 .AddFromHelperNode(ExprType.Context.Node, ExprType.Context.Tool, True)
10116 else//inherited helper not found -> delete current
10117 Params.GetHelpers(fdhlkDelphiHelper,true)
10118 .DeleteHelperNode(ClassNodeOfMethod, Self);
10119
10120 HelperForExpr := FindExtendedExprOfHelper(ClassNodeOfMethod);
10121 if HelperForExpr.Desc = xtContext then
10122 begin
10123 ExprType.Context := HelperForExpr.Context;
10124 SearchInHelpersInTheEnd := True;
10125 end;
10126 end;
10127
10128 if (not HasIdentifier) then begin
10129 // the keyword 'inherited' is the last atom
10130 if StartFlags*[fdfFindChildren,fdfFindVariable]=[fdfFindVariable] then begin
10131 // for example: inherited; search the method, not the context
10132 DefProcNode:=FindCorrespondingProcNode(ProcNode);
10133 if DefProcNode=nil then begin
10134 MoveCursorToProcName(ProcNode,true);
10135 RaiseExceptionFmt(20170421200604,ctsMethodSignatureSNotFoundInClass, [GetAtom]);
10136 end;
10137 MoveCursorToProcName(DefProcNode,true);
10138 end else begin
10139 // for example: inherited |
10140 // return the ancestor class context
10141 exit;
10142 end;
10143 end else
10144 MoveCursorToCleanPos(CurAtom.StartPos);
10145
10146 // search identifier only in class ancestor
10147 if SearchInHelpersInTheEnd then
10148 Params.Flags := Params.Flags + [fdfSearchInHelpersInTheEnd];
10149 Params.Save(OldInput);
10150 Params.SetIdentifier(Self,@Src[CurPos.StartPos],@CheckSrcIdentifier);
10151 Params.ContextNode:=ExprType.Context.Node;
10152 Params.Flags:=Params.Flags-[fdfSearchInParentNodes]
10153 +[fdfExceptionOnNotFound,fdfSearchInAncestors];
10154 ExprType.Context.Tool.FindIdentifierInContext(Params);
10155 ExprType.Context:=CreateFindContext(Params);
10156 Params.Load(OldInput,true);
10157 Params.Flags := Params.Flags - [fdfSearchInHelpersInTheEnd];
10158 end;
10159
10160 begin
10161 Result:=CleanExpressionType;
10162 FirstParamStartPos := -1;
10163 FirstParamProcContext := CleanFindContext;
10164 StartFlags:=Params.Flags;
10165 StartNode:=Params.ContextNode;
10166 {$IFDEF ShowExprEval}
10167 DebugLn(['[TFindDeclarationTool.FindExpressionTypeOfTerm] START',
10168 ' Flags=[',dbgs(Params.Flags),']',
10169 ' StartContext=',StartNode.DescAsString,'=',dbgstr(Src,StartNode.StartPos,15),
10170 ' Alias=',AliasType<>nil]
10171 );
10172 {$ENDIF}
10173 {$IFDEF CheckNodeTool}
10174 CheckNodeTool(StartNode);
10175 {$ENDIF}
10176
10177 if not InitAtomQueue then exit;
10178 ExprType:=CleanExpressionType;
10179 repeat
10180 {$IFDEF ShowExprEval}
10181 DebugLn([' FindExpressionTypeOfTerm ATOM',
10182 ' CurAtomType=',VariableAtomTypeNames[CurAtomType],
10183 ' CurAtom="',GetAtom(CurAtom),'"',
10184 ' ExprType=',ExprTypeToString(ExprType)]);
10185 {$ENDIF}
10186 case CurAtomType of
10187 vatIdentifier, vatPreDefIdentifier: ResolveIdentifier;
10188 vatStringConstant,vatNumber: ResolveConstant;
10189 vatPoint: ResolvePoint;
10190 vatAS: ResolveAs;
10191 vatUP: ResolveUp;
10192 vatEdgedBracketOpen: ResolveEdgedBracketOpen;
10193 vatRoundBracketOpen: ResolveRoundBracketOpen;
10194 vatINHERITED: ResolveINHERITED;
10195 end;
10196 ReadNextExpressionAtom;
10197 until CurAtom.EndPos>EndPos;
10198
10199 if fdfFunctionResult in StartFlags then
10200 ResolveChildren;
10201
10202 Result:=ExprType;
10203 if (Result.Desc=xtContext) and (not (fdfFindVariable in StartFlags))
10204 and (not (Result.Context.Node.Desc = ctnSpecialize)) then
10205 Result:=Result.Context.Tool.ConvertNodeToExpressionType(
10206 Result.Context.Node,Params);
10207 {$IFDEF ShowExprEval}
10208 DebugLn(' FindExpressionTypeOfTerm Result=',ExprTypeToString(Result));
10209 {$ENDIF}
10210 end;
10211
FindEndOfExpressionnull10212 function TFindDeclarationTool.FindEndOfExpression(StartPos: integer): integer;
10213 var
10214 First: Integer;
10215 begin
10216 MoveCursorToCleanPos(StartPos);
10217 Result:=CurPos.StartPos;
10218 First:=0;
10219 repeat
10220 ReadNextAtom;
10221 if First=0 then begin
10222 First:=CurPos.StartPos;
10223 if UpAtomIs('INHERITED') then begin
10224 Result:=CurPos.EndPos;
10225 ReadNextAtom;
10226 end;
10227 end;
10228 // read till statement end
10229 if (CurPos.StartPos>SrcLen)
10230 or (CurPos.Flag in [cafSemicolon,cafComma,cafEnd,
10231 cafRoundBracketClose,cafEdgedBracketClose])
10232 or (AtomIsKeyWord
10233 and not IsKeyWordInConstAllowed.DoItCaseInsensitive(Src,
10234 CurPos.StartPos,CurPos.EndPos-CurPos.StartPos))
10235 then begin
10236 break;
10237 end
10238 else if CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen] then begin
10239 ReadTilBracketClose(true);
10240 end;
10241 Result:=CurPos.EndPos;
10242 until false;
10243 end;
10244
ConvertNodeToExpressionTypenull10245 function TFindDeclarationTool.ConvertNodeToExpressionType(Node: TCodeTreeNode;
10246 Params: TFindDeclarationParams; AliasType: PFindContext): TExpressionType;
10247
10248 procedure ConvertIdentifierAtCursor(Tool: TFindDeclarationTool);
10249 begin
10250 if WordIsPredefinedIdentifier.DoItCaseInsensitive(Tool.Src,Tool.CurPos.StartPos,
10251 Tool.CurPos.EndPos-Tool.CurPos.StartPos) then
10252 begin
10253 // predefined identifiers
10254 ConvertNodeToExpressionType:=Tool.FindExpressionTypeOfPredefinedIdentifier(
10255 Tool.CurPos.StartPos,Params);
10256 end;
10257 end;
10258
10259 var
10260 BaseContext: TFindContext;
10261 OldInput: TFindDeclarationInput;
10262 Tool: TFindDeclarationTool;
10263 CurAliasType: PFindContext;
10264 begin
10265 {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF}
10266 {$IFDEF ShowExprEval}
10267 DebugLn(['[TFindDeclarationTool.ConvertNodeToExpressionType] A',
10268 ' Node=',Node.DescAsString,' "',dbgstr(copy(ExtractNode(Node,[]),1,30)),'" Flags=[',dbgs(Params.Flags),'] Alias=',AliasType<>nil]);
10269 {$ENDIF}
10270 BaseContext:=FindBaseTypeOfNode(Params,Node,AliasType);
10271 Node:=BaseContext.Node;
10272 Tool:=BaseContext.Tool;
10273 Result:=CleanExpressionType;
10274 Result.Desc:=xtContext;
10275 Result.Context:=BaseContext;
10276 {$IFDEF ShowExprEval}
10277 DebugLn('[TFindDeclarationTool.ConvertNodeToExpressionType] B',
10278 ' Expr=',ExprTypeToString(Result),' Alias=',FindContextToString(AliasType));
10279 {$ENDIF}
10280 if (AliasType<>nil) and (AliasType^.Node=nil) then
10281 CurAliasType:=AliasType
10282 else
10283 CurAliasType:=nil;
10284 case Node.Desc of
10285 ctnRangeType:
10286 begin
10287 // range type -> convert to special expression type
10288 // for example: type c = 1..3;
10289
10290 // ToDo: ppu, dcu files
10291
10292 Tool.MoveCursorToNodeStart(Node);
10293
10294 // ToDo: check for cycles
10295
10296 Params.Save(OldInput);
10297 Params.ContextNode:=Node;
10298 Result:=Tool.ReadOperandTypeAtCursor(Params,-1,CurAliasType);
10299 Params.Load(OldInput,true);
10300 Result.Context:=CreateFindContext(Tool,Node);
10301 end;
10302
10303 ctnConstDefinition:
10304 begin
10305 // const -> convert to special expression type
10306 // for example: const a: integer = 3;
10307
10308 // ToDo: ppu, dcu files
10309
10310 Tool.MoveCursorToNodeStart(Node);
10311
10312 Tool.ReadNextAtom;
10313 if not Tool.AtomIsIdentifier then exit;
10314 Tool.ReadNextAtom;
10315 if not (CurPos.Flag in [cafEqual,cafColon]) then exit;
10316 Tool.ReadNextAtom;
10317
10318 // ToDo: check for cycles
10319
10320 Params.Save(OldInput);
10321 Params.ContextNode:=Node;
10322 Result:=Tool.ReadOperandTypeAtCursor(Params,-1,CurAliasType);
10323 Params.Load(OldInput,true);
10324 Result.Context:=CreateFindContext(Tool,Node);
10325 end;
10326
10327 ctnIdentifier:
10328 begin
10329
10330 // ToDo: ppu, dcu files
10331
10332 Tool.MoveCursorToNodeStart(Node);
10333 Tool.ReadNextAtom;
10334 ConvertIdentifierAtCursor(Tool);
10335 end;
10336
10337 ctnProperty,ctnGlobalProperty:
10338 begin
10339
10340 // ToDo: ppu, dcu files
10341
10342 if Tool.MoveCursorToPropType(Node) then
10343 ConvertIdentifierAtCursor(Tool);
10344 end;
10345
10346 ctnConstant:
10347 begin
10348 // for example: const a = 3;
10349
10350 // ToDo: ppu, dcu files
10351
10352 Tool.MoveCursorToNodeStart(Node);
10353 Params.Save(OldInput);
10354 Params.ContextNode:=Node;
10355 Result:=Tool.ReadOperandTypeAtCursor(Params,-1,CurAliasType);
10356 Params.Load(OldInput,true);
10357 Result.Context:=CreateFindContext(Tool,Node);
10358 end;
10359 end;
10360
10361 {$IFDEF ShowExprEval}
10362 DebugLn('[TFindDeclarationTool.ConvertNodeToExpressionType] END',
10363 ' Expr=',ExprTypeToString(Result),' Alias=',FindContextToString(AliasType));
10364 {$ENDIF}
10365 end;
10366
ReadOperandTypeAtCursornull10367 function TFindDeclarationTool.ReadOperandTypeAtCursor(
10368 Params: TFindDeclarationParams; MaxEndPos: integer; AliasType: PFindContext
10369 ): TExpressionType;
10370 { internally used by FindExpressionResultType
10371 after reading, the cursor will be on the next atom
10372 }
10373 var EndPos, SubStartPos: integer;
10374
10375 procedure ReadEdgedBracketOperand;
10376
10377 procedure RaiseConstExpected;
10378 begin
10379 RaiseExceptionFmt(20170421200607,ctsStrExpectedButAtomFound,[ctsConstant,GetAtom]);
10380 end;
10381
10382 begin
10383 // 'set' constant
10384 SubStartPos:=CurPos.StartPos;
10385 ReadNextAtom;
10386 if not AtomIsChar(']') then begin
10387 Result:=ReadOperandTypeAtCursor(Params);
10388 {$IFDEF ShowExprEval}
10389 DebugLn('[TFindDeclarationTool.ReadOperandTypeAtCursor] Set of ',
10390 ExpressionTypeDescNames[Result.Desc]);
10391 if Result.Desc=xtContext then
10392 DebugLn(' Result.Context.Node=',Result.Context.Node.DescAsString);
10393 {$ENDIF}
10394 end else begin
10395 // empty set '[]'
10396 Result.Desc:=xtNone;
10397 end;
10398 Result.SubDesc:=Result.Desc;
10399 Result.Desc:=xtConstSet;
10400 MoveCursorToCleanPos(SubStartPos);
10401 ReadNextAtom;
10402 ReadTilBracketClose(true);
10403 MoveCursorToCleanPos(CurPos.EndPos);
10404 end;
10405
10406 procedure RaiseIdentExpected;
10407 begin
10408 RaiseExceptionFmt(20170421200609,ctsStrExpectedButAtomFound,[ctsIdentifier,GetAtom]);
10409 end;
10410
10411 var
10412 OldFlags: TFindDeclarationFlags;
10413 begin
10414 Result:=CleanExpressionType;
10415 if AliasType<>nil then
10416 AliasType^:=CleanFindContext;
10417
10418 if CurPos.StartPos=CurPos.EndPos then ReadNextAtom;
10419 // read unary operators which have no effect on the type: +, -, not
10420 while AtomIsChar('+') or AtomIsChar('-') or UpAtomIs('NOT') do
10421 ReadNextAtom;
10422 {$IFDEF ShowExprEval}
10423 DebugLn('[TFindDeclarationTool.ReadOperandTypeAtCursor] A Atom=',GetAtom);
10424 debugln(['TFindDeclarationTool.ReadOperandTypeAtCursor StartContext=',Params.ContextNode.DescAsString,'="',dbgstr(Src,Params.ContextNode.StartPos,15),'"']);
10425 {$ENDIF}
10426 if (AtomIsIdentifier)
10427 or (CurPos.Flag=cafRoundBracketOpen)
10428 or UpAtomIs('INHERITED')
10429 or UpAtomIs('ARRAY')
10430 then begin
10431 // read variable
10432 SubStartPos:=CurPos.StartPos;
10433 EndPos:=FindEndOfTerm(SubStartPos,false,true);
10434 if EndPos>MaxEndPos then
10435 EndPos:=MaxEndPos;
10436 OldFlags:=Params.Flags;
10437 Params.Flags:=(Params.Flags*fdfGlobals)+[fdfFunctionResult];
10438 Result:=FindExpressionTypeOfTerm(SubStartPos,EndPos,Params,true,AliasType);
10439 Params.Flags:=OldFlags;
10440 MoveCursorToCleanPos(EndPos);
10441 end
10442 else if UpAtomIs('NIL') then begin
10443 Result.Desc:=xtNil;
10444 ReadNextAtom;
10445 end
10446 else if AtomIsChar('[') then begin
10447 ReadEdgedBracketOperand;
10448 end
10449 else if AtomIsStringConstant then begin
10450 // string or char constant
10451 if AtomIsCharConstant then
10452 Result.Desc:=xtChar
10453 else
10454 Result.Desc:=xtConstString;
10455 MoveCursorToCleanPos(CurPos.StartPos);
10456 ReadAsStringConstant;
10457 end
10458 else if AtomIsNumber then begin
10459 // ordinal or real constant
10460 if AtomIsRealNumber then
10461 Result.Desc:=xtConstReal
10462 else
10463 Result.Desc:=xtConstOrdInteger;
10464 MoveCursorToCleanPos(CurPos.EndPos);
10465 end
10466 else if AtomIsChar('@') then begin
10467 // a simple pointer or a PChar or an event
10468 ReadNextAtom;
10469 if CurPos.Flag=cafWord then begin
10470 SubStartPos:=CurPos.StartPos;
10471 EndPos:=FindEndOfTerm(SubStartPos,false,true);
10472 if EndPos>MaxEndPos then
10473 EndPos:=MaxEndPos;
10474 OldFlags:=Params.Flags;
10475 Params.Flags:=(Params.Flags*fdfGlobals)-[fdfFunctionResult];
10476 Result:=FindExpressionTypeOfTerm(SubStartPos,EndPos,Params,true,AliasType);
10477 Params.Flags:=OldFlags;
10478 MoveCursorToCleanPos(EndPos);
10479 end else begin
10480 MoveCursorToCleanPos(CurPos.StartPos);
10481 Result:=ReadOperandTypeAtCursor(Params);
10482 end;
10483 if (Result.Desc=xtContext)
10484 or ((Result.Context.Node<>nil) and (Result.Context.Node.Desc=ctnProcedure))
10485 then begin
10486 Result.SubDesc:=Result.Desc;
10487 Result.Desc:=xtPointer;
10488 end else if (Result.Desc=xtChar) then begin
10489 Result.SubDesc:=xtNone;
10490 Result.Desc:=xtPChar
10491 end else begin
10492 Result.SubDesc:=xtNone;
10493 Result.Context:=CleanFindContext;
10494 Result.Desc:=xtPointer;
10495 end;
10496 end
10497 else
10498 RaiseIdentExpected;
10499
10500 {$IFDEF ShowExprEval}
10501 DbgOut('[TFindDeclarationTool.ReadOperandTypeAtCursor] END ',
10502 ExpressionTypeDescNames[Result.Desc]);
10503 if Result.Context.Node<>nil then
10504 DbgOut(' Context.Node=',Result.Context.Node.DescAsString)
10505 else
10506 DbgOut(' Context.Node=nil');
10507 if AliasType<>nil then
10508 DbgOut(' Alias=',FindContextToString(AliasType));
10509 DebugLn('');
10510 {$ENDIF}
10511 end;
10512
FindExpressionTypeOfPredefinedIdentifiernull10513 function TFindDeclarationTool.FindExpressionTypeOfPredefinedIdentifier(
10514 StartPos: integer; Params: TFindDeclarationParams; AliasType: PFindContext
10515 ): TExpressionType;
10516 var
10517 IdentPos: PChar;
10518 ParamList: TExprTypeList;
10519 ParamNode: TCodeTreeNode;
10520 SubParams: TFindDeclarationParams;
10521 NewTool: TFindDeclarationTool;
10522 begin
10523 Result:=CleanExpressionType;
10524 IdentPos:=@Src[StartPos];
10525 Result.Desc:=PredefinedIdentToExprTypeDesc(IdentPos,Scanner.PascalCompiler);
10526
10527 {$IFDEF ShowExprEval}
10528 debugln('TFindDeclarationTool.FindExpressionTypeOfPredefinedIdentifier "',GetIdentifier(IdentPos),'" ',
10529 ExpressionTypeDescNames[Result.Desc]);
10530 if Result.desc=xtNone then begin
10531 //CTDumpStack;
10532 //IsWordBuiltInFunc.WriteDebugListing;
10533 end;
10534 {$ENDIF}
10535 ParamList:=nil;
10536 try
10537 case Result.Desc of
10538 xtCompilerFunc:
10539 begin
10540 if not (Params.ContextNode.Desc in (AllPascalStatements+[ctnConstant])) then begin
10541 {$IFDEF ShowExprEval}
10542 debugln(['TFindDeclarationTool.FindExpressionTypeOfPredefinedIdentifier Skipping non expr parent ContextNode=',Params.ContextNode.DescAsString]);
10543 {$ENDIF}
10544 exit;
10545 end;
10546 MoveCursorToCleanPos(StartPos);
10547 ReadNextAtom;
10548 ReadNextAtom;
10549 if not AtomIsChar('(') then
10550 exit;
10551 ParamList:=CreateParamExprListFromStatement(CurPos.StartPos,Params,true);
10552 if (CompareIdentifiers(IdentPos,'PRED')=0)
10553 or (CompareIdentifiers(IdentPos,'SUCC')=0)
10554 or (CompareIdentifiers(IdentPos,'DEFAULT')=0)
10555 then begin
10556 // the DEFAULT, PRED and SUCC of a expression has the same type as the expression
10557 if ParamList.Count<>1 then exit;
10558 Result:=ParamList.Items[0];
10559 if AliasType<>nil then
10560 AliasType^:=ParamList.AliasTypes[0];
10561 //debugln(['TFindDeclarationTool.FindExpressionTypeOfPredefinedIdentifier ',ExprTypeToString(Result)]);
10562 end
10563 else if (CompareIdentifiers(IdentPos,'LOW')=0)
10564 or (CompareIdentifiers(IdentPos,'HIGH')=0) then
10565 begin
10566 {$IFDEF ShowExprEval}
10567 debugln('TFindDeclarationTool.FindExpressionTypeOfPredefinedIdentifier Ident=',GetIdentifier(IdentPos));
10568 {$ENDIF}
10569 { examples:
10570 Low(ordinal type) is the ordinal type
10571 Low(array) has type of the array items
10572 Low(set) has type of the enums
10573 }
10574 if ParamList.Count<>1 then exit;
10575 Result:=ParamList.Items[0];
10576 if Result.Desc<>xtContext then exit;
10577 ParamNode:=Result.Context.Node;
10578 case ParamNode.Desc of
10579
10580 ctnEnumerationType:
10581 // Low(enum) has the type of the enum
10582 if (ParamNode.Parent<>nil)
10583 and (ParamNode.Parent.Desc=ctnTypeDefinition) then
10584 Result.Context.Node:=ParamNode.Parent;
10585
10586 ctnOpenArrayType:
10587 // array without explicit range -> open array
10588 // Low(Open array) is ordinal integer
10589 begin
10590 Result.Desc:=xtConstOrdInteger;
10591 Result.Context:=CleanFindContext;
10592 end;
10593
10594 ctnRangedArrayType:
10595 begin
10596 // array with explicit range
10597 // Low(array[SubRange]) has the type of the subrange
10598 Result.Context.Tool.MoveCursorToNodeStart(ParamNode.FirstChild);
10599 SubParams:=TFindDeclarationParams.Create(Params);
10600 try
10601 SubParams.Flags:=fdfDefaultForExpressions;
10602 SubParams.ContextNode:=ParamNode;
10603 Result:=Result.Context.Tool.ReadOperandTypeAtCursor(SubParams);
10604 finally
10605 SubParams.Free;
10606 end;
10607 end;
10608
10609 else
10610 DebugLn('NOTE: unimplemented Low(type) type=',ParamNode.DescAsString);
10611 end;
10612 end
10613 else if (CompareIdentifiers(IdentPos,'LENGTH')=0) then
10614 begin
10615 if ParamList.Count<>1 then exit;
10616 Result.Desc:=xtConstOrdInteger;
10617 end
10618 else if (CompareIdentifiers(IdentPos,'COPY')=0) then
10619 begin
10620 if (ParamList.Count<1) or (ParamList.Count>3) or (Scanner.Values.IsDefined('VER1_0')) then
10621 exit;
10622 Result:=ParamList.Items[0]; // Copy sets the result based on the first
10623 // parameter (can be any kind of string or array)
10624 end
10625 else if (CompareIdentifiers(IdentPos,'GET_FRAME')=0) then
10626 begin
10627 if ParamList.Count<>1 then exit;
10628 Result.Desc:=xtPointer;
10629 end
10630 else if (CompareIdentifiers(IdentPos,'OBJCSELECTOR')=0) then
10631 begin
10632 // return type is System.SEL
10633 NewTool:=FindCodeToolForUsedUnit('system','',true);
10634 if NewTool=nil then exit;
10635 SubParams:=TFindDeclarationParams.Create(Params);
10636 try
10637 SubParams.Identifier:='SEL'#0;
10638 if (not NewTool.FindIdentifierInInterface(Self,SubParams))
10639 or (SubParams.NewNode=nil) then exit;
10640 Result.Desc:=xtContext;
10641 Result.Context.Node:=SubParams.NewNode;
10642 Result.Context.Tool:=SubParams.NewCodeTool;
10643 finally
10644 SubParams.Free;
10645 end;
10646 end;
10647 end;
10648
10649 xtString:
10650 Result.Desc:=GetDefaultStringType;
10651 end;
10652 finally
10653 ParamList.Free;
10654 end;
10655 end;
10656
FindExpressionTypeOfConstSetnull10657 function TFindDeclarationTool.FindExpressionTypeOfConstSet(Node: TCodeTreeNode
10658 ): TExpressionType;
10659 var
10660 AliasType: TFindContext;
10661 Params: TFindDeclarationParams;
10662 begin
10663 Result:=CleanExpressionType;
10664 if Node=nil then
10665 RaiseException(20170421212058,'TFindDeclarationTool.FindExpressionTypeOfConstSet Node=nil');
10666 {$IFDEF CheckNodeTool}
10667 CheckNodeTool(Node);
10668 {$ENDIF}
10669 MoveCursorToNodeStart(Node);
10670 ReadNextAtom;
10671 if CurPos.Flag<>cafEdgedBracketOpen then
10672 RaiseStringExpectedButAtomFound(20170421212227,'[');
10673 ReadNextAtom;
10674 Params:=TFindDeclarationParams.Create(Self,Node);
10675 try
10676 Params.Flags:=fdfDefaultForExpressions+[fdfFunctionResult];
10677 AliasType:=CleanFindContext;
10678 Result:=FindExpressionTypeOfTerm(CurPos.StartPos,-1,Params,false,@AliasType);
10679 //debugln(['TFindDeclarationTool.FindExpressionTypeOfConstSet ',ExprTypeToString(Result)]);
10680 finally
10681 Params.Free;
10682 end;
10683 end;
10684
GetDefaultStringTypenull10685 function TFindDeclarationTool.GetDefaultStringType: TExpressionTypeDesc;
10686 begin
10687 if cmsDefault_unicodestring in Scanner.CompilerModeSwitches then
10688 Result:=xtUnicodeString
10689 else if (Scanner.PascalCompiler=pcDelphi)
10690 or ((Scanner.CompilerMode=cmDELPHI)
10691 or (Scanner.Values['LONGSTRINGS']='1')) then
10692 Result:=xtAnsiString
10693 else
10694 Result:=xtString;
10695 end;
10696
CalculateBinaryOperatornull10697 function TFindDeclarationTool.CalculateBinaryOperator(LeftOperand,
10698 RightOperand: TOperand; BinaryOperator: TAtomPosition;
10699 Params: TFindDeclarationParams): TOperand;
10700 begin
10701 Result.Expr:=CleanExpressionType;
10702 Result.AliasType:=CleanFindContext;
10703 {$IFDEF ShowExprEval}
10704 DebugLn('[TFindDeclarationTool.CalculateBinaryOperator] A',
10705 ' LeftOperand=',ExprTypeToString(LeftOperand.Expr),
10706 ' Operator=',GetAtom(BinaryOperator),
10707 ' RightOperand=',ExprTypeToString(RightOperand.Expr)
10708 );
10709 {$ENDIF}
10710 // convert Left and RightOperand contexts to expressiontype
10711 if LeftOperand.Expr.Desc=xtContext then begin
10712 LeftOperand.Expr:=LeftOperand.Expr.Context.Tool.ConvertNodeToExpressionType(
10713 LeftOperand.Expr.Context.Node,Params);
10714 end;
10715 if RightOperand.Expr.Desc=xtContext then begin
10716 RightOperand.Expr:=RightOperand.Expr.Context.Tool.ConvertNodeToExpressionType(
10717 RightOperand.Expr.Context.Node,Params);
10718 end;
10719
10720
10721 // ToDo: search for an overloaded operator
10722
10723 if WordIsBooleanOperator.DoItCaseInsensitive(Src,BinaryOperator.StartPos,
10724 BinaryOperator.EndPos-BinaryOperator.StartPos)
10725 then begin
10726 // Boolean operators
10727 // < > <= >= <> in is
10728 Result.Expr.Desc:=xtBoolean;
10729 end
10730 else if (BinaryOperator.EndPos-BinaryOperator.StartPos=1)
10731 and (Src[BinaryOperator.StartPos]='/') then begin
10732 // real division /
10733 Result:=RealTypesOrderList.Compare(LeftOperand, RightOperand, Self, BinaryOperator.EndPos);
10734 if not(Result.Expr.Desc in xtAllRealTypes) then
10735 begin
10736 Result.Expr.Desc:=xtConstReal;
10737 Result.AliasType:=CleanFindContext;
10738 end;
10739 end
10740 else if WordIsOrdNumberOperator.DoItCaseInsensitive(Src,BinaryOperator.StartPos,
10741 BinaryOperator.EndPos-BinaryOperator.StartPos)
10742 then begin
10743 // ordinal number operator
10744 // or xor and mod div shl shr
10745 if LeftOperand.Expr.Desc in xtAllBooleanTypes then
10746 Result:=BooleanTypesOrderList.Compare(LeftOperand, RightOperand, Self, BinaryOperator.EndPos)
10747 else
10748 Result:=IntegerTypesOrderList.Compare(LeftOperand, RightOperand, Self, BinaryOperator.EndPos);
10749 end
10750 else if WordIsNumberOperator.DoItCaseInsensitive(Src,BinaryOperator.StartPos,
10751 BinaryOperator.EndPos-BinaryOperator.StartPos)
10752 then begin
10753 // number operator (or string concatenating or set cut)
10754 // + - *
10755
10756 if (Src[BinaryOperator.StartPos]='+')
10757 and (LeftOperand.Expr.Desc in xtAllStringCompatibleTypes)
10758 then begin
10759 // string/char '+'
10760 if (RightOperand.Expr.Desc in xtAllStringCompatibleTypes)
10761 then
10762 begin
10763 Result:=StringTypesOrderList.Compare(LeftOperand, RightOperand, Self, BinaryOperator.EndPos);
10764 if not(Result.Expr.Desc in xtAllStringTypes) then
10765 begin
10766 Result.Expr.Desc:=xtConstString;
10767 Result.AliasType:=CleanFindContext;
10768 end;
10769 end else begin
10770 MoveCursorToCleanPos(BinaryOperator.EndPos);
10771 ReadNextAtom;
10772 RaiseExceptionFmt(20170421200612,ctsIncompatibleTypesGotExpected,
10773 ['char',ExpressionTypeDescNames[RightOperand.Expr.Desc]]);
10774 end;
10775 end else if (Src[BinaryOperator.StartPos] in ['+','-','*'])
10776 and (LeftOperand.Expr.Desc=xtContext)
10777 and (LeftOperand.Expr.Context.Node<>nil)
10778 and (LeftOperand.Expr.Context.Node.Desc=ctnSetType)
10779 then begin
10780 Result:=LeftOperand;
10781 end else begin
10782 if (LeftOperand.Expr.Desc in xtAllRealTypes)
10783 or (RightOperand.Expr.Desc in xtAllRealTypes) then
10784 Result:=RealTypesOrderList.Compare(LeftOperand, RightOperand, Self, BinaryOperator.EndPos)
10785 else if (LeftOperand.Expr.Desc=xtPointer)
10786 or (RightOperand.Expr.Desc=xtPointer)
10787 or ((LeftOperand.Expr.Desc=xtContext)
10788 and (LeftOperand.Expr.Context.Node.Desc=ctnPointerType))
10789 or ((RightOperand.Expr.Desc=xtContext)
10790 and (RightOperand.Expr.Context.Node.Desc=ctnPointerType))
10791 then
10792 Result.Expr.Desc:=xtPointer
10793 else
10794 Result:=IntegerTypesOrderList.Compare(LeftOperand, RightOperand, Self, BinaryOperator.EndPos);
10795 end;
10796 end else begin
10797 // ???
10798 {$IFDEF ShowExprEval}
10799 debugln(['TFindDeclarationTool.CalculateBinaryOperator unknown operator: ',GetAtom(BinaryOperator)]);
10800 {$ENDIF}
10801 Result:=RightOperand;
10802 end;
10803 end;
10804
IsParamExprListCompatibleToNodeListnull10805 function TFindDeclarationTool.IsParamExprListCompatibleToNodeList(
10806 FirstTargetParameterNode: TCodeTreeNode;
10807 SourceExprParamList: TExprTypeList; IgnoreMissingParameters: boolean;
10808 Params: TFindDeclarationParams;
10809 CompatibilityList: TTypeCompatibilityList): TTypeCompatibility;
10810 // tests if SourceExprParamList fits into the TargetFirstParameterNode
10811 var
10812 ParamNode: TCodeTreeNode;
10813 i, MinParamCnt, MaxParamCnt: integer;
10814 ParamCompatibility: TTypeCompatibility;
10815 CompatibilityListCount: LongInt;
10816 begin
10817 {$IFDEF CheckNodeTool}CheckNodeTool(FirstTargetParameterNode);{$ENDIF}
10818 // quick check: parameter count
10819 ParamNode:=FirstTargetParameterNode;
10820 MinParamCnt:=0;
10821 while (ParamNode<>nil)
10822 and ((ParamNode.SubDesc and ctnsHasDefaultValue)=0) do begin
10823 ParamNode:=ParamNode.NextBrother;
10824 inc(MinParamCnt);
10825 end;
10826 MaxParamCnt:=MinParamCnt;
10827 while (ParamNode<>nil) do begin
10828 ParamNode:=ParamNode.NextBrother;
10829 inc(MaxParamCnt);
10830 end;
10831
10832 {$IF defined(ShowExprEval) or defined(ShowProcSearch)}
10833 DebugLn('[TFindDeclarationTool.IsParamExprListCompatibleToNodeList] ',
10834 ' ExprParamList.Count=',dbgs(SourceExprParamList.Count),
10835 ' MinParamCnt=',dbgs(MinParamCnt),' MaxParamCnt=',dbgs(MaxParamCnt)
10836 );
10837 try
10838 {$ENDIF}
10839 Result:=tcExact;
10840
10841 if (SourceExprParamlist.Count>MaxParamCnt)
10842 or ((not IgnoreMissingParameters) and (SourceExprParamList.Count<MinParamCnt))
10843 then begin
10844 Result:=tcIncompatible;
10845 exit;
10846 end;
10847
10848 // check each parameter for compatibility
10849 ParamNode:=FirstTargetParameterNode;
10850 i:=0;
10851 CompatibilityListCount:=SourceExprParamList.Count;
10852 while (ParamNode<>nil) and (i<CompatibilityListCount) do begin
10853 ParamCompatibility:=IsCompatible(ParamNode,SourceExprParamList.Items[i],
10854 Params);
10855 {$IF defined(ShowExprEval) or defined(ShowProcSearch)}
10856 DebugLn(['[TFindDeclarationTool.IsParamExprListCompatibleToNodeList] SourceParam=',ExprTypeToString(SourceExprParamList.Items[i]),' TargetParam=',ExtractNode(ParamNode,[]),' ',TypeCompatibilityNames[ParamCompatibility]]);
10857 {$ENDIF}
10858 if CompatibilityList<>nil then
10859 CompatibilityList[i]:=ParamCompatibility;
10860 if (ParamCompatibility=tcIncompatible)
10861 or ((ParamCompatibility=tcCompatible)
10862 and MoveCursorToParameterSpecifier(ParamNode)
10863 and (UpAtomIs('VAR') or UpAtomIs('CONSTREF')
10864 or (UpAtomIs('OUT') and (cmsOut in Scanner.CompilerModeSwitches))))
10865 then begin
10866 Result:=tcIncompatible;
10867 exit;
10868 end;
10869 if ParamCompatibility=tcCompatible then
10870 Result:=tcCompatible;
10871 ParamNode:=ParamNode.NextBrother;
10872 inc(i);
10873 end;
10874 if (i<SourceExprParamList.Count) then begin
10875 // there are more expressions, then the param list has variables
10876 Result:=tcIncompatible;
10877 end else if (ParamNode<>nil) then begin
10878 // there are not enough expressions for the param list
10879 // -> check if missing variables have default variables
10880 if (ParamNode.SubDesc and ctnsHasDefaultValue)>0 then begin
10881 // the rest params have default values
10882 if CompatibilityList<>nil then begin
10883 while (ParamNode<>nil) and (i<CompatibilityListCount) do begin
10884 CompatibilityList[i]:=tcExact;
10885 ParamNode:=ParamNode.NextBrother;
10886 inc(i);
10887 end;
10888 end;
10889 end else if not IgnoreMissingParameters then begin
10890 // not enough expression for param list
10891 // -> incompatible
10892 Result:=tcIncompatible;
10893 end;
10894 end;
10895 {$IF defined(ShowExprEval) or defined(ShowProcSearch)}
10896 finally
10897 DebugLn('[TFindDeclarationTool.IsParamExprListCompatibleToNodeList] END ',
10898 ' Result=',TypeCompatibilityNames[Result],' ! ONLY VALID if no error !'
10899 );
10900 end;
10901 {$ENDIF}
10902 end;
10903
IsParamNodeListCompatibleToExprListnull10904 function TFindDeclarationTool.IsParamNodeListCompatibleToExprList(
10905 TargetExprParamList: TExprTypeList; FirstSourceParameterNode: TCodeTreeNode;
10906 Params: TFindDeclarationParams;
10907 CompatibilityList: TTypeCompatibilityList): TTypeCompatibility;
10908 // tests if FirstSourceParameterNode fits (i.e. can be assigned) into
10909 // the TargetExprParamList
10910 var
10911 ParamNode: TCodeTreeNode;
10912 i, MinParamCnt, MaxParamCnt: integer;
10913 ParamCompatibility: TTypeCompatibility;
10914 SourceExprType: TExpressionType;
10915 begin
10916 {$IFDEF CheckNodeTool}CheckNodeTool(FirstSourceParameterNode);{$ENDIF}
10917
10918 // quick check: parameter count
10919 MinParamCnt:=0;
10920 ParamNode:=FirstSourceParameterNode;
10921 while (ParamNode<>nil) do begin
10922 ParamNode:=ParamNode.NextBrother;
10923 inc(MinParamCnt);
10924 end;
10925 MaxParamCnt:=MinParamCnt;
10926
10927 {$IFDEF ShowExprEval}
10928 DebugLn('[TFindDeclarationTool.IsParamNodeListCompatibleToExprList] ',
10929 ' ExprParamList.Count=',dbgs(TargetExprParamList.Count),' ',
10930 ' MinParamCnt=',dbgs(MinParamCnt),' MaxParamCnt=',dbgs(MaxParamCnt)
10931 );
10932 try
10933 {$ENDIF}
10934 Result:=tcExact;
10935
10936 if (TargetExprParamList.Count<>MaxParamCnt) then begin
10937 Result:=tcIncompatible;
10938 exit;
10939 end;
10940
10941 // check each parameter for compatibility
10942
10943 {$IFDEF ShowExprEval}
10944 DebugLn('[TFindDeclarationTool.IsParamNodeListCompatibleToExprList] ',
10945 ' ExprParamList=[',TargetExprParamList.AsString,']');
10946 {$ENDIF}
10947 ParamNode:=FirstSourceParameterNode;
10948 i:=0;
10949 while (ParamNode<>nil) and (i<TargetExprParamList.Count) do begin
10950 SourceExprType:=ConvertNodeToExpressionType(ParamNode,Params);
10951 ParamCompatibility:=IsCompatible(TargetExprParamList.Items[i],
10952 SourceExprType,Params);
10953 {$IFDEF ShowExprEval}
10954 DebugLn(['[TFindDeclarationTool.IsParamNodeListCompatibleToExprList] B ',i,' Source=[',ExprTypeToString(SourceExprType),'] Target=[',ExprTypeToString(TargetExprParamList.Items[i]),'] Result=',TypeCompatibilityNames[ParamCompatibility]]);
10955 {$ENDIF}
10956 if CompatibilityList<>nil then
10957 CompatibilityList[i]:=ParamCompatibility;
10958 if ParamCompatibility=tcIncompatible then begin
10959 Result:=tcIncompatible;
10960 exit;
10961 end else if ParamCompatibility=tcCompatible then begin
10962 Result:=tcCompatible;
10963 end;
10964 ParamNode:=ParamNode.NextBrother;
10965 inc(i);
10966 end;
10967 if (ParamNode<>nil) or (i<TargetExprParamList.Count) then
10968 RaiseException(20170421200618,'Internal Error: one param list has changed');
10969
10970 {$IFDEF ShowExprEval}
10971 finally
10972 DebugLn('[TFindDeclarationTool.IsParamNodeListCompatibleToExprList] END ',
10973 ' Result=',TypeCompatibilityNames[Result],' ! ONLY VALID if no error !'
10974 );
10975 end;
10976 {$ENDIF}
10977 end;
10978
IsParamNodeListCompatibleToParamNodeListnull10979 function TFindDeclarationTool.IsParamNodeListCompatibleToParamNodeList(
10980 FirstTargetParameterNode, FirstSourceParameterNode: TCodeTreeNode;
10981 Params: TFindDeclarationParams;
10982 CompatibilityList: TTypeCompatibilityList): TTypeCompatibility;
10983 var
10984 CurParamNode1, CurParamNode2: TCodeTreeNode;
10985 ParamCompatibility: TTypeCompatibility;
10986 SourceExprType, TargetExprType: TExpressionType;
10987 OldFlags: TFindDeclarationFlags;
10988 i: integer;
10989 begin
10990 {$IFDEF CheckNodeTool}CheckNodeTool(FirstTargetParameterNode);{$ENDIF}
10991 // quick check: parameter count
10992 CurParamNode1:=FirstTargetParameterNode;
10993 CurParamNode2:=FirstSourceParameterNode;
10994 while (CurParamNode1<>nil) and (CurParamNode2<>nil) do begin
10995 CurParamNode1:=CurParamNode1.NextBrother;
10996 CurParamNode2:=CurParamNode2.NextBrother;
10997 end;
10998 if (CurParamNode1<>nil) or (CurParamNode2<>nil) then begin
10999 Result:=tcIncompatible;
11000 exit;
11001 end;
11002
11003 // check each parameter
11004 OldFlags:=Params.Flags;
11005 Params.Flags:=Params.Flags-[fdfFindVariable]+[fdfIgnoreOverloadedProcs];
11006 CurParamNode1:=FirstTargetParameterNode;
11007 CurParamNode2:=FirstSourceParameterNode;
11008 Result:=tcExact;
11009 i:=0;
11010 while (CurParamNode1<>nil) and (CurParamNode2<>nil) do begin
11011 TargetExprType:=ConvertNodeToExpressionType(CurParamNode1,Params);
11012 SourceExprType:=ConvertNodeToExpressionType(CurParamNode2,Params);
11013 ParamCompatibility:=IsBaseCompatible(TargetExprType,SourceExprType,Params);
11014 if CompatibilityList<>nil then
11015 CompatibilityList[i]:=ParamCompatibility;
11016 if ParamCompatibility=tcIncompatible then begin
11017 Result:=tcIncompatible;
11018 exit;
11019 end else if ParamCompatibility=tcCompatible then begin
11020 Result:=tcCompatible;
11021 end;
11022 CurParamNode1:=CurParamNode1.NextBrother;
11023 CurParamNode2:=CurParamNode2.NextBrother;
11024 inc(i);
11025 end;
11026 Params.Flags:=OldFlags;
11027 end;
11028
GetParameterNodenull11029 function TFindDeclarationTool.GetParameterNode(Node: TCodeTreeNode
11030 ): TCodeTreeNode;
11031 begin
11032 {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF}
11033 Result:=Node;
11034 if Result=nil then exit;
11035 if Result.Desc=ctnReferenceTo then begin
11036 Result:=Result.FirstChild;
11037 if Result=nil then exit;
11038 end;
11039 if (Result.Desc in [ctnProperty,ctnGlobalProperty]) then
11040 Result:=Result.FirstChild
11041 else if Result.Desc in [ctnProcedure,ctnProcedureHead,ctnProcedureType] then begin
11042 BuildSubTreeForProcHead(Result);
11043 if Result.Desc in [ctnProcedure,ctnProcedureType] then
11044 Result:=Result.FirstChild;
11045 if Result.Desc=ctnProcedureHead then
11046 Result:=Result.FirstChild;
11047 end;
11048 end;
11049
GetFirstParameterNodenull11050 function TFindDeclarationTool.GetFirstParameterNode(Node: TCodeTreeNode
11051 ): TCodeTreeNode;
11052 begin
11053 Result:=GetParameterNode(Node);
11054 if Result<>nil then Result:=Result.FirstChild;
11055 end;
11056
CheckSrcIdentifiernull11057 function TFindDeclarationTool.CheckSrcIdentifier(
11058 Params: TFindDeclarationParams;
11059 const FoundContext: TFindContext): TIdentifierFoundResult;
11060 // this is a TOnIdentifierFound function
11061 // if identifier found is a proc then it searches for the best overloaded proc
11062
11063 function CallHasEmptyParamsAndFoundProcFits: boolean;
11064 var
11065 FirstParameterNode: TCodeTreeNode;
11066 TargetTool: TFindDeclarationTool;
11067 begin
11068 Result:=false;
11069 FirstParameterNode:=FoundContext.Tool.GetFirstParameterNode(
11070 FoundContext.Node);
11071 if (FirstParameterNode<>nil)
11072 and ((FirstParameterNode.SubDesc and ctnsHasDefaultValue)=0) then begin
11073 // found proc needs at least one parameter
11074 exit;
11075 end;
11076 // FoundContext is a proc with no or only default params
11077 TargetTool:=Params.IdentifierTool;
11078 TargetTool.MoveCursorToCleanPos(Params.Identifier);
11079 TargetTool.ReadNextAtom; // read identifier
11080 TargetTool.ReadNextAtom; // read bracket
11081 if TargetTool.CurPos.Flag<>cafRoundBracketOpen then exit;
11082 TargetTool.ReadNextAtom; // read bracket close
11083 if TargetTool.CurPos.Flag<>cafRoundBracketClose then exit;
11084 Result:=true;
11085 end;
11086
11087 var
11088 FirstParameterNode, StartContextNode: TCodeTreeNode;
11089 ParamCompatibility: TTypeCompatibility;
11090 OldInput: TFindDeclarationInput;
11091 CurCompatibilityList: TTypeCompatibilityList;
11092 CompListSize: integer;
11093 NewExprInputList: TExprTypeList;
11094 begin
11095 // the search has found an identifier with the right name
11096 {$IFDEF ShowFoundIdentifier}
11097 DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]',
11098 ' Ident=',GetIdentifier(Params.Identifier),
11099 ' FoundContext=',FoundContext.Node.DescAsString,
11100 ' Flags=[',dbgs(Params.Flags),']'
11101 );
11102 {$ENDIF}
11103 if FoundContext.Node.Desc=ctnProcedure then begin
11104 // the found node is a proc
11105
11106 // 1. the current identifier cache is blind for parameter lists
11107 // => proc identifiers can not be identified by the name alone
11108 // -> do not cache
11109 // 2. Even if there is only one proc. With different search flags,
11110 // different routes will be searched and then there can be another proc.
11111 // The only solution is to store the param expression list and all flags
11112 // in the cache. This is a ToDo
11113 Include(Params.Flags,fdfDoNotCache);
11114 Include(Params.NewFlags,fodDoNotCache);
11115
11116 if (fdfIgnoreOverloadedProcs in Params.Flags) then begin
11117 // do not check for overloaded procs -> ident found
11118 Result:=ifrSuccess;
11119 exit;
11120 end;
11121
11122 // Procs can be overloaded, that means there can be several procs with the
11123 // same name, but with different param lists.
11124 // The search must go on, and the most compatible proc is returned.
11125
11126 if not Params.IdentifierTool.IsPCharInSrc(Params.Identifier) then begin
11127 // Params.Identifier is not in the source of the start tool
11128 // => impossible to check param list, because the context is unknown
11129 // -> identifier found
11130 {$IFDEF ShowProcSearch}
11131 DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]',
11132 ' Ident=',GetIdentifier(Params.Identifier),
11133 ' NO SOURCE to check params'
11134 );
11135 {$ENDIF}
11136 Result:=ifrSuccess;
11137 exit;
11138 end;
11139
11140 if FoundContext.Tool.NodeIsClassConstructorOrDestructor(FoundContext.Node) then
11141 begin
11142 Result:=ifrProceedSearch;
11143 Exit;
11144 end;
11145
11146 if (not (fdfCollect in Params.Flags))
11147 and CallHasEmptyParamsAndFoundProcFits then begin
11148 // call has brackets without params (e.g. writeln() )
11149 // and found proc fits exactly
11150 // => stop search
11151 {$IF defined(ShowFoundIdentifier) or defined(ShowProcSearch)}
11152 debugln(['TFindDeclarationTool.CheckSrcIdentifier call is () and found proc fits exactly',
11153 ' Ident=',GetIdentifier(Params.Identifier),
11154 ' ',FoundContext.Tool.CleanPosToStr(FoundContext.Node.StartPos)
11155 ]);
11156 {$ENDIF}
11157 Params.SetResult(FoundContext);
11158 Result:=ifrSuccess;
11159 exit;
11160 end;
11161
11162 Result:=ifrProceedSearch;
11163 if (Params.FoundProc=nil) then begin
11164 // this is the first proc found
11165 // -> save it and proceed the search to find all overloadeded procs
11166 {$IF defined(ShowFoundIdentifier) or defined(ShowProcSearch)}
11167 DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]',
11168 ' Ident=',GetIdentifier(Params.Identifier),
11169 ' ',FoundContext.Tool.CleanPosToStr(FoundContext.Node.StartPos),
11170 ' FIRST PROC searching for overloads ...'
11171 );
11172 {$ENDIF}
11173 Params.SetFoundProc(FoundContext);
11174 exit;
11175 end;
11176
11177 // -> check which one is more compatible
11178 // create the input expression list
11179 // (the expressions in the brackets are parsed and converted to types)
11180 if Params.FoundProc^.ExprInputList=nil then begin
11181 {$IF defined(ShowFoundIdentifier) or defined(ShowProcSearch)}
11182 DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]',
11183 ' Ident=',GetIdentifier(Params.Identifier),
11184 ' Creating Input Expression List ...'
11185 );
11186 {$ENDIF}
11187 if Params.IdentifierTool.IsPCharInSrc(Params.Identifier) then begin
11188 Params.IdentifierTool.MoveCursorToCleanPos(Params.Identifier);
11189 StartContextNode:=Params.IdentifierTool.FindDeepestNodeAtPos(
11190 Params.IdentifierTool.CurPos.StartPos,true);
11191 if (StartContextNode<>nil) then begin
11192 if (StartContextNode.Desc in AllPascalStatements) then begin
11193 {$IFDEF ShowProcSearch}
11194 DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]',
11195 ' Ident=',GetIdentifier(Params.Identifier),
11196 ' Creating Input Expression List for statement ...'
11197 );
11198 {$ENDIF}
11199 Params.Save(OldInput);
11200 Params.IdentifierTool.MoveCursorToCleanPos(Params.Identifier);
11201 Params.Flags:=fdfDefaultForExpressions+Params.Flags*fdfGlobals;
11202 Params.ContextNode:=StartContextNode;
11203 Params.OnIdentifierFound:=@Params.IdentifierTool.CheckSrcIdentifier;
11204 Params.IdentifierTool.ReadNextAtom;
11205 NewExprInputList:=
11206 Params.IdentifierTool.CreateParamExprListFromStatement(
11207 Params.IdentifierTool.CurPos.EndPos,Params);
11208 {$IFDEF ShowProcSearch}
11209 debugln(['TFindDeclarationTool.CheckSrcIdentifier Params: ',NewExprInputList.AsString]);
11210 {$ENDIF}
11211 Params.Load(OldInput,true);
11212 FreeAndNil(Params.FoundProc^.ExprInputList);
11213 Params.FoundProc^.ExprInputList:=NewExprInputList;
11214 end
11215 else if (StartContextNode.Desc in [ctnProcedureHead,ctnProcedure])
11216 then begin
11217 {$IFDEF ShowProcSearch}
11218 DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]',
11219 ' Ident=',GetIdentifier(Params.Identifier),
11220 ' Creating Input Expression List for proc node ...'
11221 );
11222 {$ENDIF}
11223 NewExprInputList:=
11224 Params.IdentifierTool.CreateParamExprListFromProcNode(
11225 StartContextNode,Params);
11226 {$IFDEF ShowProcSearch}
11227 debugln(['TFindDeclarationTool.CheckSrcIdentifier Params: ',NewExprInputList.AsString]);
11228 {$ENDIF}
11229 FreeAndNil(Params.FoundProc^.ExprInputList);
11230 Params.FoundProc^.ExprInputList:=NewExprInputList;
11231 end;
11232 end;
11233 end;
11234 if Params.FoundProc^.ExprInputList=nil then begin
11235 // create expression list without params
11236 Params.FoundProc^.ExprInputList:=TExprTypeList.Create;
11237 end;
11238 end;
11239
11240 // create compatibility lists for params
11241 // (each parameter is checked for compatibility)
11242 CompListSize:=SizeOf(TTypeCompatibility)
11243 *Params.FoundProc^.ExprInputList.Count;
11244 if (CompListSize>0)
11245 and (Params.FoundProc^.ParamCompatibilityList=nil) then begin
11246 GetMem(Params.FoundProc^.ParamCompatibilityList,CompListSize);
11247 //DebugLn(['TFindDeclarationTool.CheckSrcIdentifier FoundProc=',dbgs(Params.FoundProc),' New ParamCompatibilityList=',dbgs(Params.FoundProc^.ParamCompatibilityList),' CompListSize=',CompListSize]);
11248 end else begin
11249 //DebugLn(['TFindDeclarationTool.CheckSrcIdentifier FoundProc=',dbgs(Params.FoundProc),' Old ParamCompatibilityList=',dbgs(Params.FoundProc^.ParamCompatibilityList),' CompListSize=',CompListSize]);
11250 end;
11251
11252 // check the first found proc for compatibility
11253 // (compare the expression list with the proc param list)
11254 if not Params.FoundProc^.CacheValid then begin
11255 {$IF defined(ShowFoundIdentifier) or defined(ShowProcSearch)}
11256 DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]',
11257 ' Ident=',GetIdentifier(Params.Identifier),
11258 ' Check the first found proc for compatibility ...'
11259 );
11260 {$ENDIF}
11261 FirstParameterNode:=Params.FoundProc^.Context.Tool.GetFirstParameterNode(
11262 Params.FoundProc^.Context.Node);
11263 ParamCompatibility:=
11264 Params.FoundProc^.Context.Tool.IsParamExprListCompatibleToNodeList(
11265 FirstParameterNode,
11266 Params.FoundProc^.ExprInputList,
11267 fdfIgnoreMissingParams in Params.Flags,
11268 Params,Params.FoundProc^.ParamCompatibilityList);
11269 Params.FoundProc^.ProcCompatibility:=ParamCompatibility;
11270 Params.FoundProc^.CacheValid:=true;
11271 if ParamCompatibility=tcExact then begin
11272 Params.SetResult(Params.FoundProc^.Context.Tool,
11273 Params.FoundProc^.Context.Node.FirstChild);
11274 end;
11275 end;
11276
11277 if Params.FoundProc^.ProcCompatibility=tcExact then begin
11278 {$IF defined(ShowFoundIdentifier) or defined(ShowProcSearch)}
11279 DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]',
11280 ' Ident=',GetIdentifier(Params.Identifier),
11281 ' First Proc ParamCompatibility=',TypeCompatibilityNames[Params.FoundProc^.ProcCompatibility]
11282 );
11283 {$ENDIF}
11284 // the first proc fits exactly -> stop the search
11285 Result:=ifrSuccess;
11286 exit;
11287 end;
11288
11289 // check the current proc for compatibility
11290 // (compare the expression list with the proc param list)
11291 {$IF defined(ShowFoundIdentifier) or defined(ShowProcSearch)}
11292 DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]',
11293 ' Ident=',GetIdentifier(Params.Identifier),
11294 ' Check the current found proc for compatibility ...'
11295 );
11296 {$ENDIF}
11297 if CompListSize>0 then begin
11298 GetMem(CurCompatibilityList,CompListSize);
11299 //DebugLn(['TFindDeclarationTool.CheckSrcIdentifier create temp CurCompatibilityList=',dbgs(CurCompatibilityList),' CompListSize=',CompListSize]);
11300 end else begin
11301 CurCompatibilityList:=nil;
11302 end;
11303 try
11304 FirstParameterNode:=
11305 FoundContext.Tool.GetFirstParameterNode(FoundContext.Node);
11306 ParamCompatibility:=
11307 FoundContext.Tool.IsParamExprListCompatibleToNodeList(
11308 FirstParameterNode,
11309 Params.FoundProc^.ExprInputList,
11310 fdfIgnoreMissingParams in Params.Flags,
11311 Params,CurCompatibilityList);
11312 {$IF defined(ShowFoundIdentifier) or defined(ShowProcSearch)}
11313 DebugLn('[TFindDeclarationTool.CheckSrcIdentifier]',
11314 ' Ident=',GetIdentifier(Params.Identifier),
11315 ' Current Proc ParamCompatibility=',TypeCompatibilityNames[ParamCompatibility]
11316 );
11317 {$ENDIF}
11318 if ParamCompatibility=tcExact then begin
11319 // the current proc fits exactly -> stop the search
11320 Params.ChangeFoundProc(FoundContext,ParamCompatibility,
11321 CurCompatibilityList);
11322 CurCompatibilityList:=nil; // set to nil, so that it will not be freed
11323 Params.SetResult(FoundContext.Tool,FoundContext.Node.FirstChild);
11324 Result:=ifrSuccess;
11325 end else if ParamCompatibility=tcCompatible then begin
11326 // the proc fits not exactly, but is compatible
11327 if (Params.FoundProc^.ProcCompatibility=tcInCompatible)
11328 or CompatibilityList1IsBetter(CurCompatibilityList,
11329 Params.FoundProc^.ParamCompatibilityList,
11330 Params.FoundProc^.ExprInputList.Count) then
11331 begin
11332 // the new proc fits better
11333 Params.ChangeFoundProc(FoundContext,ParamCompatibility,CurCompatibilityList);
11334 CurCompatibilityList:=nil; // set to nil, so that it will not be freed
11335 end;
11336 end;
11337 finally
11338 // end overloaded proc search
11339 if CurCompatibilityList<>nil then begin
11340 //DebugLn(['TFindDeclarationTool.CheckSrcIdentifier free CurCompatibilityList=',dbgs(CurCompatibilityList)]);
11341 FreeMem(CurCompatibilityList);
11342 end;
11343 end;
11344 end else
11345 if (FoundContext.Node.Desc=ctnVarDefinition) then begin
11346 if not (fdfIgnoreClassVisibility in Params.Flags)
11347 and (FoundContext.Tool<>Params.IdentifierTool)
11348 and (GetClassVisibility(FoundContext.Node)=ctnClassPrivate) then
11349 Result:=ifrProceedSearch
11350 else
11351 Result:=ifrSuccess;
11352 end else begin
11353 Result:=ifrSuccess;
11354 end;
11355 end;
11356
DoOnIdentifierFoundnull11357 function TFindDeclarationTool.DoOnIdentifierFound(
11358 Params: TFindDeclarationParams;
11359 FoundNode: TCodeTreeNode): TIdentifierFoundResult;
11360 // this internal function is called, whenever an identifier is found
11361 var IsTopLvlIdent: boolean;
11362 begin
11363 {$IFDEF CheckNodeTool}CheckNodeTool(FoundNode);{$ENDIF}
11364 IsTopLvlIdent:=(fdfTopLvlResolving in Params.Flags);
11365 if Assigned(Params.OnIdentifierFound) then
11366 Result:=Params.OnIdentifierFound(Params,CreateFindContext(Self,FoundNode))
11367 else
11368 Result:=ifrSuccess;
11369 if (Result=ifrSuccess) and IsTopLvlIdent
11370 and Assigned(Params.OnTopLvlIdentifierFound) then
11371 Params.OnTopLvlIdentifierFound(Params,CreateFindContext(Self,FoundNode));
11372 end;
11373
IsCompatiblenull11374 function TFindDeclarationTool.IsCompatible(TargetNode: TCodeTreeNode;
11375 const ExpressionType: TExpressionType;
11376 Params: TFindDeclarationParams): TTypeCompatibility;
11377 var TargetContext: TFindContext;
11378 OldInput: TFindDeclarationInput;
11379 NodeExprType: TExpressionType;
11380 begin
11381 {$IFDEF CheckNodeTool}CheckNodeTool(TargetNode);{$ENDIF}
11382 {$IFDEF ShowExprEval}
11383 DebugLn('[TFindDeclarationTool.IsCompatible] A Node=',TargetNode.DescAsString,
11384 ' ExpressionType=',ExpressionTypeDescNames[ExpressionType.Desc]);
11385 {$ENDIF}
11386 Result:=tcIncompatible;
11387 // find base type of node
11388 OldInput.Flags:=Params.Flags;
11389 Include(Params.Flags,fdfExceptionOnNotFound);
11390 TargetContext:=FindBaseTypeOfNode(Params,TargetNode);
11391 Params.Flags:=OldInput.Flags;
11392
11393 // compare node base type and ExpressionType
11394 if (ExpressionType.Context.Node<>nil)
11395 and (ExpressionType.Context.Node=TargetContext.Node) then begin
11396 // same base type
11397 Result:=tcExact;
11398 end
11399 else if (TargetContext.Node.Desc=ctnGenericParameter)
11400 or ((ExpressionType.Desc=xtContext)
11401 and (ExpressionType.Context.Node.Desc=ctnGenericParameter))
11402 then begin
11403 // generic type is always preferred
11404 Result:=tcExact;
11405 end
11406 else if (TargetContext.Node.Desc=ctnSetType) then begin
11407 {$IFDEF ShowExprEval}
11408 DebugLn('[TFindDeclarationTool.IsCompatible] TargetContext.Node.Desc=ctnSetType',
11409 ' "',copy(TargetContext.Tool.Src,TargetContext.Node.Parent.StartPos,20),'"');
11410 {$ENDIF}
11411 if (ExpressionType.Desc=xtConstSet) then begin
11412 // both are sets, compare type of sets
11413 if (ExpressionType.SubDesc<>xtNone) then begin
11414
11415 // ToDo: check if enums of expression fits into enums of target
11416
11417 // ToDo: ppu, dcu
11418
11419 Result:=tcCompatible;
11420 end else
11421 // the empty set is compatible to all kinds of sets
11422 Result:=tcExact;
11423 end else begin
11424
11425 end;
11426 end else begin
11427 NodeExprType:=CleanExpressionType;
11428 NodeExprType.Desc:=xtContext;
11429 NodeExprType.Context:=CreateFindContext(Self,TargetNode);
11430 Result:=IsCompatible(NodeExprType,ExpressionType,Params);
11431 end;
11432 {$IFDEF ShowExprEval}
11433 DebugLn('[TFindDeclarationTool.IsCompatible] END',
11434 ' BaseNode=',TargetContext.Node.DescAsString,
11435 ' ExpressionType=',ExpressionTypeDescNames[ExpressionType.Desc],
11436 ' Result=',TypeCompatibilityNames[Result]
11437 );
11438 {$ENDIF}
11439 end;
11440
IsCompatiblenull11441 function TFindDeclarationTool.IsCompatible(TargetType,
11442 ExpressionType: TExpressionType; Params: TFindDeclarationParams
11443 ): TTypeCompatibility;
11444 begin
11445 if TargetType.Desc=xtContext then begin
11446 if TargetType.Context.Node.Desc=ctnGenericParameter then
11447 exit(tcExact);
11448 TargetType:=TargetType.Context.Tool.ConvertNodeToExpressionType(
11449 TargetType.Context.Node,Params);
11450 end;
11451 if ExpressionType.Desc=xtContext then begin
11452 if ExpressionType.Context.Node.Desc=ctnGenericParameter then
11453 exit(tcExact);
11454 ExpressionType:=ExpressionType.Context.Tool.ConvertNodeToExpressionType(
11455 ExpressionType.Context.Node,Params);
11456 end;
11457 Result:=IsBaseCompatible(TargetType,ExpressionType,Params);
11458 end;
11459
GetCurrentAtomTypenull11460 function TFindDeclarationTool.GetCurrentAtomType: TVariableAtomType;
11461 var
11462 Node: TCodeTreeNode;
11463 c: Char;
11464 begin
11465 //debugln(['TFindDeclarationTool.GetCurrentAtomType ',CurPos.StartPos,' ',CurPos.EndPos,' ',SrcLen,' ',GetAtom]);
11466 if (CurPos.StartPos=CurPos.EndPos) then
11467 exit(vatSpace)
11468 else if (CurPos.StartPos<1) or (CurPos.StartPos>SrcLen) then
11469 exit(vatNone);
11470 c:=Src[CurPos.StartPos];
11471 if IsIdentStartChar[c] then begin
11472 if WordIsPredefinedIdentifier.DoItCaseInsensitive(Src,CurPos.StartPos,
11473 CurPos.EndPos-CurPos.StartPos) then
11474 exit(vatPreDefIdentifier)
11475 else if UpAtomIs('INHERITED') then
11476 exit(vatINHERITED)
11477 else if UpAtomIs('AS') then
11478 exit(vatAS)
11479 else if WordIsKeyWord.DoItCaseInsensitive(Src,CurPos.StartPos,
11480 CurPos.EndPos-CurPos.StartPos) then
11481 exit(vatKeyWord)
11482 else if UpAtomIs('PROPERTY') then begin
11483 Node:=FindDeepestNodeAtPos(CurPos.StartPos,false);
11484 if (Node<>nil) and (Node.Desc in [ctnProperty,ctnPropertySection]) then
11485 exit(vatKeyword)
11486 else
11487 exit(vatIdentifier);
11488 end else
11489 exit(vatIdentifier);
11490 end else if (CurPos.StartPos=CurPos.EndPos-1) then begin
11491 case c of
11492 '.': exit(vatPoint);
11493 '^': exit(vatUp);
11494 '(': exit(vatRoundBracketOpen);
11495 ')': exit(vatRoundBracketClose);
11496 '[': exit(vatEdgedBracketOpen);
11497 ']': exit(vatEdgedBracketClose);
11498 '@': exit(vatAddrOp);
11499 else exit(vatNone);
11500 end;
11501 end
11502 else begin
11503 case c of
11504 '''','#': exit(vatStringConstant);
11505 '&':
11506 begin
11507 if (CurPos.StartPos+1=CurPos.EndPos) then exit(vatNone);
11508 c:=Src[CurPos.StartPos+1];
11509 if IsIdentStartChar[c] then begin
11510 // &keyword
11511 exit(vatIdentifier);
11512 end else if IsNumberChar[c] then
11513 exit(vatNumber) // octal
11514 else exit(vatNone);
11515 end;
11516 else exit(vatNone);
11517 end;
11518 end;
11519 end;
11520
CreateParamExprListFromStatementnull11521 function TFindDeclarationTool.CreateParamExprListFromStatement(
11522 StartPos: integer; Params: TFindDeclarationParams; GetAlias: boolean
11523 ): TExprTypeList;
11524 var ExprType: TExpressionType;
11525 BracketClose: char;
11526 ExprStartPos, ExprEndPos: integer;
11527 CurIgnoreErrorAfterPos: Integer;
11528 OldFlags: TFindDeclarationFlags;
11529 ok: Boolean;
11530 AliasType: TFindContext;
11531
11532 procedure RaiseBracketNotFound;
11533 begin
11534 RaiseExceptionFmt(20170421200621,ctsStrExpectedButAtomFound,[BracketClose,GetAtom]);
11535 end;
11536
11537 begin
11538 {$IFDEF ShowExprEval}
11539 DebugLn('[TFindDeclarationTool.CreateParamExprListFromStatement] ',
11540 '"',copy(Src,StartPos,40),'" Context=',Params.ContextNode.DescAsString);
11541 {$ENDIF}
11542 Result:=TExprTypeList.Create;
11543 ok:=false;
11544 try
11545 MoveCursorToCleanPos(StartPos);
11546 ReadNextAtom; // reads first atom after proc name
11547 if AtomIsChar('(') then
11548 BracketClose:=')'
11549 else if AtomIsChar('[') then
11550 BracketClose:=']'
11551 else
11552 BracketClose:=#0;
11553 if IgnoreErrorAfterValid then
11554 CurIgnoreErrorAfterPos:=IgnoreErrorAfterCleanedPos
11555 else
11556 CurIgnoreErrorAfterPos:=-1;
11557 OldFlags:=Params.Flags;
11558 if BracketClose<>#0 then begin
11559 // read parameter list
11560 ReadNextAtom;
11561 if not AtomIsChar(BracketClose) then begin
11562 // read all expressions
11563 while true do begin
11564 ExprStartPos:=CurPos.StartPos;
11565 // read til comma or bracket close
11566 repeat
11567 if CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen] then begin
11568 ReadTilBracketClose(true);
11569 end;
11570 ReadNextAtom;
11571 if (CurPos.StartPos>SrcLen)
11572 or (CurPos.Flag in [cafRoundBracketClose,cafEdgedBracketClose,cafComma])
11573 then
11574 break;
11575 until false;
11576 ExprEndPos:=CurPos.StartPos;
11577 // find expression type
11578 if (CurIgnoreErrorAfterPos>=ExprStartPos) then
11579 Params.Flags:=Params.Flags-[fdfExceptionOnNotFound];
11580 //DebugLn('TFindDeclarationTool.CreateParamExprListFromStatement CurIgnoreErrorAfterPos=',dbgs(CurIgnoreErrorAfterPos),' ExprStartPos=',dbgs(ExprStartPos));
11581 if GetAlias then begin
11582 AliasType:=CleanFindContext;
11583 ExprType:=FindExpressionResultType(Params,ExprStartPos,ExprEndPos,@AliasType);
11584 Result.Add(ExprType,AliasType);
11585 end else begin
11586 ExprType:=FindExpressionResultType(Params,ExprStartPos,ExprEndPos);
11587 Result.Add(ExprType);
11588 end;
11589 MoveCursorToCleanPos(ExprEndPos);
11590 ReadNextAtom;
11591 if AtomIsChar(BracketClose) then break;
11592 if not AtomIsChar(',') then
11593 RaiseBracketNotFound;
11594 ReadNextAtom;
11595 end;
11596 end;
11597 end;
11598 Params.Flags:=OldFlags;
11599 {$IFDEF ShowExprEval}
11600 DebugLn('[TFindDeclarationTool.CreateParamExprListFromStatement] END ',
11601 'ParamCount=',dbgs(Result.Count),' "',copy(Src,StartPos,40),'"');
11602 DebugLn(' ExprList=[',Result.AsString,']');
11603 {$ENDIF}
11604 Ok:=true;
11605 finally
11606 if not Ok then Result.Free;
11607 end;
11608 end;
11609
CreateParamExprListFromProcNodenull11610 function TFindDeclarationTool.CreateParamExprListFromProcNode(
11611 ProcNode: TCodeTreeNode; Params: TFindDeclarationParams): TExprTypeList;
11612 var
11613 ExprType: TExpressionType;
11614 ParamNode: TCodeTreeNode;
11615 begin
11616 {$IFDEF CheckNodeTool}CheckNodeTool(ProcNode);{$ENDIF}
11617 {$IFDEF ShowExprEval}
11618 DebugLn('[TFindDeclarationTool.CreateParamExprListFromProcNode] ',
11619 '"',copy(Src,ProcNode.StartPos,40),'" Context=',ProcNode.DescAsString);
11620 {$ENDIF}
11621 Result:=TExprTypeList.Create;
11622 ParamNode:=GetFirstParameterNode(ProcNode);
11623 while ParamNode<>nil do begin
11624 // find expression type
11625 ExprType:=ConvertNodeToExpressionType(ParamNode,Params);
11626 // add expression type to list
11627 Result.Add(ExprType);
11628 ParamNode:=ParamNode.NextBrother;
11629 end;
11630 {$IFDEF ShowExprEval}
11631 DebugLn('[TFindDeclarationTool.CreateParamExprListFromProcNode] END ',
11632 'ParamCount=',dbgs(Result.Count),' "',copy(Src,ProcNode.StartPos,40),'"');
11633 DebugLn(' ExprList=[',Result.AsString,']');
11634 {$ENDIF}
11635 end;
11636
CompatibilityList1IsBetternull11637 function TFindDeclarationTool.CompatibilityList1IsBetter( List1,
11638 List2: TTypeCompatibilityList; ListCount: integer): boolean;
11639 // List1 and List2 should only contain tcCompatible and tcExact values
11640 var i: integer;
11641 begin
11642 // search first difference, start at end
11643 i:=ListCount-1;
11644 while (i>=0) and (List1[i]=List2[i]) do dec(i);
11645 // List1 is better, if first difference is better for List1
11646 Result:=(i>=0) and (List1[i]=tcExact);
11647 {$IFDEF ShowFoundIdentifier}
11648 DebugLn('[TFindDeclarationTool.CompatibilityList1IsBetter] END i=',dbgs(i));
11649 {$ENDIF}
11650 end;
11651
ContextIsDescendOfnull11652 function TFindDeclarationTool.ContextIsDescendOf(const DescendContext,
11653 AncestorContext: TFindContext; Params: TFindDeclarationParams): boolean;
11654
11655 procedure RaiseInternalError;
11656 begin
11657 RaiseException(20170421200624,'[TFindDeclarationTool.ContextIsDescendOf] '
11658 +' internal error: DescendContext.Desc<>ctnClass');
11659 end;
11660
11661 var CurContext: TFindContext;
11662 OldInput: TFindDeclarationInput;
11663 begin
11664 if not (DescendContext.Node.Desc in AllClasses) then
11665 RaiseInternalError;
11666 {$IFDEF ShowExprEval}
11667 DebugLn('[TFindDeclarationTool.ContextIsDescendOf] ',
11668 ' DescendContext="',copy(DescendContext.Tool.Src,DescendContext.Node.Parent.StartPos,15),'"');
11669 {$ENDIF}
11670 CurContext:=DescendContext;
11671 Params.Save(OldInput);
11672 repeat
11673 Result:=CurContext.Tool.FindAncestorOfClass(CurContext.Node,Params,true);
11674 if Result then begin
11675 CurContext:=CreateFindContext(Params);
11676 {$IFDEF ShowExprEval}
11677 DebugLn('[TFindDeclarationTool.ContextIsDescendOf] B ',
11678 ' CurContext="',copy(CurContext.Tool.Src,CurContext.Node.Parent.StartPos,15),'"');
11679 {$ENDIF}
11680 Result:=FindContextAreEqual(CurContext,AncestorContext);
11681 if Result then exit;
11682 end else
11683 break;
11684 until false;
11685 Result:=false;
11686 end;
11687
IsBaseCompatiblenull11688 function TFindDeclarationTool.IsBaseCompatible(const TargetType,
11689 ExpressionType: TExpressionType; Params: TFindDeclarationParams
11690 ): TTypeCompatibility;
11691 // test if ExpressionType can be assigned to TargetType
11692 // both expression types must be base types
11693 var TargetNode, ExprNode: TCodeTreeNode;
11694 begin
11695 {$IFDEF ShowExprEval}
11696 DebugLn('[TFindDeclarationTool.IsBaseCompatible] START ',
11697 ' TargetType=',ExprTypeToString(TargetType),
11698 ' ExpressionType=',ExprTypeToString(ExpressionType));
11699 {$ENDIF}
11700 Result:=tcIncompatible;
11701 if (TargetType.Desc=xtContext)
11702 and (TargetType.Context.Node.Desc=ctnGenericParameter) then
11703 exit(tcExact);
11704 if (ExpressionType.Desc=xtContext)
11705 and (ExpressionType.Context.Node.Desc=ctnGenericParameter) then
11706 exit(tcExact);
11707 if (TargetType.Desc=ExpressionType.Desc) then begin
11708 case TargetType.Desc of
11709
11710 xtNone: ;
11711
11712 xtContext:
11713 begin
11714 TargetNode:=TargetType.Context.Node;
11715 ExprNode:=ExpressionType.Context.Node;
11716 {$IFDEF ShowExprEval}
11717 DebugLn('[TFindDeclarationTool.IsBaseCompatible] C ',
11718 ' TargetContext="',copy(TargetType.Context.Tool.Src,TargetType.Context.Node.StartPos,20),'"',
11719 ' ExpressionContext="',copy(ExpressionType.Context.Tool.Src,ExpressionType.Context.Node.StartPos,20),'"'
11720 );
11721 {$ENDIF}
11722 if TargetNode=ExprNode then
11723 Result:=tcExact
11724 else
11725 if ExprNode.Desc=TargetNode.Desc then begin
11726 // same context type
11727 case ExprNode.Desc of
11728
11729 ctnClass, ctnClassInterface, ctnDispinterface, ctnObject, ctnRecordType,
11730 ctnClassHelper, ctnRecordHelper, ctnTypeHelper,
11731 ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass:
11732 // check, if ExpressionType.Context descends from TargetContext
11733 if ContextIsDescendOf(ExpressionType.Context,
11734 TargetType.Context,Params)
11735 then
11736 Result:=tcExact;
11737
11738 ctnRangedArrayType,ctnOpenArrayType:
11739 // ToDo: check range and type of arrayfields
11740 begin
11741 Result:=tcCompatible;
11742 end;
11743
11744 end;
11745 end else begin
11746 // different context type
11747
11748 end;
11749 end;
11750 else
11751 Result:=tcExact;
11752 end;
11753
11754 end else if ((TargetType.Desc=xtPointer)
11755 and (ExpressionType.Desc=xtContext)
11756 and (ExpressionType.Context.Node.Desc in AllClasses))
11757 then begin
11758 // assigning a class to a pointer
11759 Result:=tcExact;
11760
11761 end else begin
11762 // check, if ExpressionType can be auto converted into TargetType
11763 if ((TargetType.Desc in xtAllRealTypes)
11764 and (ExpressionType.Desc in xtAllRealConvertibles))
11765 or ((TargetType.Desc in xtAllStringTypes)
11766 and (ExpressionType.Desc in xtAllStringConvertibles))
11767 or ((TargetType.Desc in xtAllWideStringTypes)
11768 and (ExpressionType.Desc in xtAllWideStringCompatibleTypes))
11769 or ((TargetType.Desc in xtAllIntegerTypes)
11770 and (ExpressionType.Desc in xtAllIntegerConvertibles))
11771 or ((TargetType.Desc in xtAllBooleanTypes)
11772 and (ExpressionType.Desc in xtAllBooleanConvertibles))
11773 or ((TargetType.Desc in xtAllPointerTypes)
11774 and (ExpressionType.Desc in xtAllPointerConvertibles))
11775 or (TargetType.Desc=xtJSValue)
11776 then
11777 Result:=tcCompatible
11778 else if (TargetType.Desc=xtContext) then begin
11779 TargetNode:=TargetType.Context.Node;
11780 if ((TargetNode.Desc in (AllClasses+[ctnProcedure]))
11781 and (ExpressionType.Desc=xtNil))
11782 or ((TargetNode.Desc in [ctnOpenArrayType,ctnRangedArrayType])
11783 and (TargetNode.LastChild<>nil)
11784 and (TargetNode.LastChild.Desc=ctnOfConstType)
11785 and (ExpressionType.Desc=xtConstSet))
11786 then
11787 Result:=tcCompatible
11788 end
11789 else if (ExpressionType.Desc=xtContext) then begin
11790 ExprNode:=ExpressionType.Context.Node;
11791 if (TargetType.Desc=xtFile) and (ExprNode.Desc=ctnFileType)
11792 then
11793 Result:=tcCompatible
11794 end;
11795 end;
11796 {$IFDEF ShowExprEval}
11797 DebugLn('[TFindDeclarationTool.IsBaseCompatible] END ',
11798 ' TargetType=',ExpressionTypeDescNames[TargetType.Desc],
11799 ' ExpressionType=',ExpressionTypeDescNames[ExpressionType.Desc],
11800 ' Result=',TypeCompatibilityNames[Result]
11801 );
11802 {$ENDIF}
11803 end;
11804
CheckParameterSyntaxnull11805 function TFindDeclarationTool.CheckParameterSyntax(StartPos,
11806 CleanCursorPos: integer; out ParameterAtom, ProcNameAtom: TAtomPosition; out
11807 ParameterIndex: integer): boolean;
11808 // check for Identifier(expr,expr,...,expr,VarName
11809 // or Identifier[expr,expr,...,expr,VarName
11810 // ParameterIndex is 0 based
11811 {off $DEFINE VerboseCPS}
11812
11813 procedure RaiseBracketNotOpened;
11814 begin
11815 if CurPos.Flag=cafRoundBracketClose then
11816 RaiseExceptionFmt(20170421200628,ctsBracketNotFound,['('])
11817 else
11818 RaiseExceptionFmt(20170421200630,ctsBracketNotFound,['[']);
11819 end;
11820
11821 function CheckIdentifierAndParameterList: boolean; forward;
11822
11823 function CheckBrackets: boolean;
11824 { check simple brackets (no identifier in front of brackets)
11825 }
11826 var
11827 BracketAtom: TAtomPosition;
11828 begin
11829 BracketAtom:=CurPos;
11830 {$IFDEF VerboseCPS}DebugLn('CheckBrackets "',GetAtom,'" BracketAtom=',dbgs(BracketAtom));{$ENDIF}
11831 repeat
11832 ReadNextAtom;
11833 if CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen] then begin
11834 if (LastAtoms.GetPriorAtom.Flag=cafWord) then begin
11835 {$IFDEF VerboseCPS}DebugLn('CheckBrackets check word+bracket open');{$ENDIF}
11836 UndoReadNextAtom;
11837 if CheckIdentifierAndParameterList() then exit(true);
11838 end else begin
11839 {$IFDEF VerboseCPS}DebugLn('CheckBrackets check bracket open');{$ENDIF}
11840 if CheckBrackets() then exit(true);
11841 end;
11842 end else if CurPos.Flag in [cafRoundBracketClose,cafEdgedBracketClose]
11843 then begin
11844 if (BracketAtom.Flag=cafRoundBracketOpen)
11845 =(CurPos.Flag=cafRoundBracketClose)
11846 then begin
11847 // closing bracket found, but the variable was not in them
11848 {$IFDEF VerboseCPS}DebugLn('CheckBrackets bracket closed');{$ENDIF}
11849 exit(false);
11850 end else begin
11851 // invalid closing bracket found
11852 RaiseBracketNotOpened;
11853 end;
11854 end;
11855 until (CurPos.EndPos>CleanCursorPos);
11856 Result:=false;
11857 end;
11858
11859 function CheckIdentifierAndParameterList: boolean;
11860 { when called: CursorPos is at an identifier followed by a ( or [
11861 }
11862 var
11863 BracketAtom: TAtomPosition;
11864 CurProcNameAtom: TAtomPosition;
11865 CurParameterIndex: Integer;
11866 ParameterStart: integer;
11867 begin
11868 Result:=false;
11869 if CurPos.Flag<>cafWord then exit;
11870 CurProcNameAtom:=CurPos;
11871 CurParameterIndex:=0;
11872 {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList START "',GetAtom,'" ',dbgs(CurProcNameAtom));{$ENDIF}
11873 ReadNextAtom;
11874 if not (CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen]) then exit;
11875 BracketAtom:=CurPos;
11876 ParameterStart:=CurPos.EndPos;
11877 {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList Bracket="',GetAtom,'"');{$ENDIF}
11878 repeat
11879 ReadNextAtom;
11880 {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList Atom="',GetAtom,'"');{$ENDIF}
11881 if (CurPos.EndPos>CleanCursorPos)
11882 or ((CurPos.EndPos=CleanCursorPos)
11883 and ((CurPos.Flag=cafWord) or AtomIsChar('@')))
11884 then begin
11885 // parameter found => search parameter expression bounds e.g. ', parameter ,'
11886 // important: this function should work, even if the code
11887 // behind CleanCursorPos has syntax errors
11888 {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList Parameter found, search range ...');{$ENDIF}
11889 ProcNameAtom:=CurProcNameAtom;
11890 ParameterIndex:=CurParameterIndex;
11891 ParameterAtom.StartPos:=ParameterStart;
11892 ParameterAtom.EndPos:=ParameterStart;
11893 MoveCursorToCleanPos(ParameterStart);
11894 repeat
11895 ReadNextAtom;
11896 {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList parameter atom "',GetAtom,'"');{$ENDIF}
11897 if (CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen]) then
11898 begin
11899 // atom belongs to the parameter expression
11900 if ParameterAtom.StartPos=ParameterAtom.EndPos then
11901 ParameterAtom.StartPos:=CurPos.StartPos;
11902 ReadTilBracketClose(false);
11903 ParameterAtom.EndPos:=CurPos.EndPos;
11904 end
11905 else
11906 if (CurPos.StartPos>SrcLen)
11907 or (CurPos.Flag in [cafComma,cafSemicolon,cafEnd,
11908 cafRoundBracketClose,cafEdgedBracketClose])
11909 or ((CurPos.Flag=cafWord)
11910 and (LastAtoms.GetPriorAtom.Flag=cafWord)
11911 and (not LastUpAtomIs(0,'INHERITED'))) then
11912 begin
11913 // end of parameter expression found
11914 {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList end of parameter found "',GetAtom,'" Parameter="',dbgstr(Src,ParameterAtom.StartPos,ParameterAtom.EndPos-ParameterAtom.StartPos),'"');{$ENDIF}
11915 exit(true);
11916 end else begin
11917 // atom belongs to the parameter expression
11918 if ParameterAtom.StartPos=ParameterAtom.EndPos then
11919 ParameterAtom.StartPos:=CurPos.StartPos;
11920 ParameterAtom.EndPos:=CurPos.EndPos;
11921 end;
11922 until false;
11923 end;
11924 if (CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen]) then begin
11925 if (LastAtoms.GetPriorAtom.Flag=cafWord) then begin
11926 {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList check word+bracket open');{$ENDIF}
11927 UndoReadNextAtom;
11928 if CheckIdentifierAndParameterList() then exit(true);
11929 end else begin
11930 {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList check bracket open');{$ENDIF}
11931 if CheckBrackets then exit(true);
11932 end;
11933 end
11934 else if CurPos.Flag in [cafRoundBracketClose,cafEdgedBracketClose] then
11935 begin
11936 {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList check bracket close');{$ENDIF}
11937 if (BracketAtom.Flag=cafRoundBracketOpen)
11938 =(CurPos.Flag=cafRoundBracketClose)
11939 then begin
11940 // parameter list ended in front of Variable => continue search
11941 {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList parameter list ended in front of cursor');{$ENDIF}
11942 if CurPos.Flag=cafEdgedBracketClose then begin
11943 ReadNextAtom;
11944 if CurPos.Flag=cafEdgedBracketOpen then begin
11945 // [][] is equal to [,]
11946 ParameterStart:=CurPos.EndPos;
11947 inc(CurParameterIndex);
11948 continue;
11949 end else
11950 UndoReadNextAtom;
11951 end;
11952 exit;
11953 end else begin
11954 // invalid closing bracket found
11955 RaiseBracketNotOpened;
11956 end;
11957 end;
11958 // finally after checking the expression: count commas
11959 if CurPos.Flag=cafComma then begin
11960 ParameterStart:=CurPos.EndPos;
11961 inc(CurParameterIndex);
11962 end;
11963 {$IFDEF VerboseCPS}DebugLn('CheckIdentifierAndParameterList After parsing atom. atom="',GetAtom,'"');{$ENDIF}
11964 until (CurPos.EndPos>CleanCursorPos);
11965 end;
11966
11967 var
11968 CommentStart: integer;
11969 CommentEnd: integer;
11970 CleanPosInFront: Integer;
11971 begin
11972 Result:=false;
11973 ParameterAtom:=CleanAtomPosition;
11974 ProcNameAtom:=CleanAtomPosition;
11975 ParameterIndex:=0;
11976 //DebugLn('TFindDeclarationTool.CheckParameterSyntax START');
11977
11978 if StartPos<1 then exit;
11979 // read code in front to find ProcName and check the syntax
11980 MoveCursorToCleanPos(StartPos);
11981 repeat
11982 ReadNextAtom;
11983 {$IFDEF VerboseCPS}
11984 DebugLn('TFindDeclarationTool.CheckParameterSyntax ',GetAtom,' at ',CleanPosToStr(CurPos.StartPos),' ',dbgs(CurPos.EndPos),'<',dbgs(CleanCursorPos));
11985 {$ENDIF}
11986 if CurPos.EndPos>CleanCursorPos then begin
11987 if not LastAtoms.HasPrior then exit;
11988 CleanPosInFront:=LastAtoms.GetPriorAtom.EndPos;
11989 //debugln(['TFindDeclarationTool.CheckParameterSyntax Cur="',GetAtom,'" Last="',GetAtom(LastAtoms.GetValueAt(0)),'"']);
11990 if not CleanPosIsInComment(CleanCursorPos,CleanPosInFront,
11991 CommentStart,CommentEnd,false) then exit;
11992 // cursor in a comment
11993 // => parse within the comment
11994 MoveCursorToCleanPos(CommentStart);
11995 end else if (CurPos.Flag in [cafRoundBracketOpen,cafEdgedBracketOpen])
11996 and (LastAtoms.GetPriorAtom.Flag=cafWord) then begin
11997 UndoReadNextAtom;
11998 if CheckIdentifierAndParameterList then exit(true);
11999 if CurPos.EndPos>CleanCursorPos then exit;
12000 end;
12001 until false;
12002 end;
12003
12004 procedure TFindDeclarationTool.OnFindUsedUnitIdentifier(
12005 Sender: TPascalParserTool; IdentifierCleanPos: integer; Range: TEPRIRange;
12006 Node: TCodeTreeNode; Data: Pointer; var Abort: boolean);
12007 var
12008 Identifier: PChar;
12009 CacheEntry: PInterfaceIdentCacheEntry;
12010 refs: TFindUsedUnitReferences;
12011 Found: Boolean;
12012 ReferencePos: TCodeXYPosition;
12013 begin
12014 if Range=epriInDirective then exit;
12015 if not (Node.Desc in (AllPascalTypes+AllPascalStatements)) then exit;
12016 Identifier:=@Src[IdentifierCleanPos];
12017 refs:=TFindUsedUnitReferences(Data);
12018 CacheEntry:=refs.TargetTool.FInterfaceIdentifierCache.FindIdentifier(Identifier);
12019 //debugln(['TFindUsedUnitReferences.OnIdentifier Identifier=',GetIdentifier(Identifier),' Found=',CacheEntry<>nil]);
12020 if (CacheEntry=nil)
12021 and (CompareIdentifiers(Identifier,PChar(refs.TargetUnitName))<>0) then
12022 exit;
12023 Sender.MoveCursorToCleanPos(IdentifierCleanPos);
12024 Sender.ReadPriorAtom;
12025 if (Sender.CurPos.Flag=cafPoint) or (Sender.UpAtomIs('inherited')) then exit;
12026 //debugln(['TFindUsedUnitReferences.OnIdentifier Identifier=',GetIdentifier(Identifier),' at begin of term']);
12027 // find declaration
12028 refs.Params.Clear;
12029 refs.Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors,
12030 fdfIgnoreCurContextNode];
12031 refs.Params.ContextNode:=Node;
12032 //debugln(copy(Src,Params.ContextNode.StartPos,200));
12033 refs.Params.SetIdentifier(Self,Identifier,@CheckSrcIdentifier);
12034
12035 if Range=epriInCode then begin
12036 // search identifier in code
12037 Found:=FindDeclarationOfIdentAtParam(refs.Params);
12038 end else begin
12039 // search identifier in comment -> if not found, this is no problem
12040 // => silently ignore
12041 try
12042 Found:=FindDeclarationOfIdentAtParam(refs.Params);
12043 except
12044 on E: ECodeToolError do begin
12045 // continue
12046 end;
12047 on E: Exception do
12048 raise;
12049 end;
12050 end;
12051 //debugln(['TFindUsedUnitReferences.OnIdentifier Identifier=',GetIdentifier(Identifier),' found=',Found]);
12052
12053 if not Found then exit;
12054
12055 if CleanPosToCaret(IdentifierCleanPos,ReferencePos) then
12056 AddCodePosition(refs.ListOfPCodeXYPosition,ReferencePos);
12057 end;
12058
FindNthParameterNodenull12059 function TFindDeclarationTool.FindNthParameterNode(Node: TCodeTreeNode;
12060 ParameterIndex: integer): TCodeTreeNode;
12061 var
12062 ProcNode, FunctionNode: TCodeTreeNode;
12063 ProcHeadNode: TCodeTreeNode;
12064 ParameterNode: TCodeTreeNode;
12065 i: Integer;
12066 begin
12067 {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF}
12068 Result:=nil;
12069 if Node=nil then exit;
12070 if Node.Desc=ctnReferenceTo then begin
12071 Node:=Node.FirstChild;
12072 if Node=nil then exit;
12073 end;
12074 if Node.Desc in [ctnProcedure,ctnProcedureType] then begin
12075 ProcNode:=Node;
12076 //DebugLn(' FindNthParameterNode ProcNode="',copy(Params.NewCodeTool.Src,ProcNode.StartPos,ProcNode.EndPos-ProcNode.StartPos),'"');
12077 FunctionNode:=nil;
12078 BuildSubTreeForProcHead(ProcNode,FunctionNode);
12079 // find procedure head
12080 ProcHeadNode:=ProcNode.FirstChild;
12081 if (ProcHeadNode=nil) or (ProcHeadNode.Desc<>ctnProcedureHead) then begin
12082 DebugLn(' FindNthParameterNode Procedure has no parameter list');
12083 exit;
12084 end;
12085 // find parameter list
12086 ParameterNode:=ProcHeadNode.FirstChild;
12087 if (ParameterNode=nil) or (ParameterNode.Desc<>ctnParameterList)
12088 then begin
12089 DebugLn(' FindNthParameterNode Procedure has no parameter list');
12090 exit;
12091 end;
12092 // find parameter
12093 ParameterNode:=ParameterNode.FirstChild;
12094 i:=0;
12095 while (i<ParameterIndex) and (ParameterNode<>nil) do begin
12096 //DebugLn(' FindNthParameterNode ',ParameterNode.DescAsString);
12097 ParameterNode:=ParameterNode.NextBrother;
12098 inc(i);
12099 end;
12100 Result:=ParameterNode;
12101 end;
12102 end;
12103
12104 constructor TFindDeclarationTool.Create;
12105 begin
12106 inherited Create;
12107 FSourcesChangeStep:=CTInvalidChangeStamp64;
12108 FFilesChangeStep:=CTInvalidChangeStamp64;
12109 FInitValuesChangeStep:=CTInvalidChangeStamp;
12110 end;
12111
12112 procedure TFindDeclarationTool.DoDeleteNodes(StartNode: TCodeTreeNode);
12113 var
12114 HelperKind: TFDHelpersListKind;
12115 begin
12116 ClearNodeCaches;
12117 if FInterfaceIdentifierCache<>nil then begin
12118 FInterfaceIdentifierCache.Clear;
12119 FInterfaceIdentifierCache.Complete:=false;
12120 end;
12121 for HelperKind in TFDHelpersListKind do
12122 if FInterfaceHelperCache[HelperKind]<>nil then
12123 FInterfaceHelperCache[HelperKind].Clear;
12124 inherited DoDeleteNodes(StartNode);
12125 end;
12126
CheckDependsOnNodeCachesnull12127 function TFindDeclarationTool.CheckDependsOnNodeCaches(
12128 CheckedTools: TAVLTree = nil): boolean;
12129 var
12130 ANode: TAVLTreeNode;
12131 ATool: TFindDeclarationTool;
12132 FreeCheckedTools: Boolean;
12133 SourcesChangeStep, FilesChangeStep: int64;
12134 InitValuesChangeStep: integer;
12135 begin
12136 Result:=false;
12137 //debugln(['TFindDeclarationTool.CheckDependsOnNodeCaches ',MainFilename,' FDependsOnCodeTools=',FDependsOnCodeTools]);
12138 if (FDependsOnCodeTools=nil) or FCheckingNodeCacheDependencies then exit;
12139 if Scanner=nil then exit;
12140
12141 if Assigned(Scanner.OnGetGlobalChangeSteps) then begin
12142 // check if any sources or values have changed
12143 Scanner.OnGetGlobalChangeSteps(SourcesChangeStep,FilesChangeStep,
12144 InitValuesChangeStep);
12145 if (SourcesChangeStep=FSourcesChangeStep)
12146 and (FilesChangeStep=FFilesChangeStep)
12147 and (InitValuesChangeStep=FInitValuesChangeStep) then
12148 // all sources and values are the same
12149 exit;
12150 FSourcesChangeStep:=SourcesChangeStep;
12151 FFilesChangeStep:=FilesChangeStep;
12152 FInitValuesChangeStep:=InitValuesChangeStep;
12153 end;
12154
12155 if (CheckedTools<>nil) and (CheckedTools.Find(Self)<>nil) then exit;
12156
12157 {$IFDEF ShowCacheDependencies}
12158 DebugLn(['[TFindDeclarationTool.CheckDependsOnNodeCaches] START DependsOn=',FDependsOnCodeTools.Count,' ',MainFilename]);
12159 {$ENDIF}
12160 FCheckingNodeCacheDependencies:=true;
12161 FreeCheckedTools:=false;
12162 if CheckedTools=nil then begin
12163 FreeCheckedTools:=true;
12164 CheckedTools:=TAVLTree.Create;
12165 end;
12166 try
12167 CheckedTools.Add(Self);
12168 ANode:=FDependsOnCodeTools.FindLowest;
12169 while ANode<>nil do begin
12170 ATool:=TFindDeclarationTool(ANode.Data);
12171 Result:=ATool.UpdateNeeded(lsrImplementationStart)
12172 or ATool.CheckDependsOnNodeCaches(CheckedTools);
12173 if Result then exit;
12174 ANode:=FDependsOnCodeTools.FindSuccessor(ANode);
12175 end;
12176 Result:=false;
12177 finally
12178 {$IFDEF ShowCacheDependencies}
12179 DebugLn('[TFindDeclarationTool.CheckDependsOnNodeCaches] Result=',DbgS(Result),' ',MainFilename);
12180 {$ENDIF}
12181 FCheckingNodeCacheDependencies:=false;
12182 if FreeCheckedTools then FreeAndNil(CheckedTools);
12183 if Result then ClearNodeCaches;
12184 end;
12185 end;
12186
12187 destructor TFindDeclarationTool.Destroy;
12188 var
12189 HelperKind: TFDHelpersListKind;
12190 begin
12191 FreeAndNil(FInterfaceIdentifierCache);
12192 for HelperKind in TFDHelpersListKind do
12193 FreeAndNil(FInterfaceHelperCache[HelperKind]);
12194 FreeAndNil(FDependsOnCodeTools);
12195 FreeAndNil(FDependentCodeTools);
12196 if FDirectoryCache<>nil then begin
12197 FDirectoryCache.Release;
12198 FDirectoryCache:=nil;
12199 end;
12200 FFindMissingFPCUnits.Free;
12201 inherited Destroy;
12202 end;
12203
12204 procedure TFindDeclarationTool.ClearNodeCaches;
12205 var
12206 NodeCache: TCodeTreeNodeCache;
12207 BaseTypeCache: TBaseTypeCache;
12208 begin
12209 // check if there is something in cache to delete
12210 if (FFirstNodeCache=nil) and (FFirstBaseTypeCache=nil)
12211 and (FRootNodeCache=nil)
12212 and ((FDependentCodeTools=nil) or (FDependentCodeTools.Count=0))
12213 and ((FDependsOnCodeTools=nil) or (FDependsOnCodeTools.Count=0)) then
12214 exit;
12215 {$IFDEF ShowCacheDependencies}
12216 DebugLn('[TFindDeclarationTool.ClearNodeCaches] Force=',
12217 DbgS(Force),' ',MainFilename);
12218 {$ENDIF}
12219
12220 // clear node caches
12221 while FFirstNodeCache<>nil do begin
12222 NodeCache:=FFirstNodeCache;
12223 FFirstNodeCache:=NodeCache.Next;
12224 NodeCacheMemManager.DisposeNodeCache(NodeCache);
12225 end;
12226 while FFirstBaseTypeCache<>nil do begin
12227 BaseTypeCache:=FFirstBaseTypeCache;
12228 FFirstBaseTypeCache:=BaseTypeCache.NextCache;
12229 BaseTypeCacheMemManager.DisposeBaseTypeCache(BaseTypeCache);
12230 end;
12231 if FRootNodeCache<>nil then begin
12232 NodeCacheMemManager.DisposeNodeCache(FRootNodeCache);
12233 FRootNodeCache:=nil;
12234 end;
12235
12236 // clear dependent codetools
12237 ClearDependentNodeCaches;
12238 ClearDependsOnToolRelationships;
12239 end;
12240
12241 procedure TFindDeclarationTool.ClearDependentNodeCaches;
12242 var
12243 ANode: TAVLTreeNode;
12244 DependentTool: TFindDeclarationTool;
12245 begin
12246 if (FDependentCodeTools=nil) or (FDependentCodeTools.Count=0)
12247 or FClearingDependentNodeCaches then exit;
12248 FClearingDependentNodeCaches:=true;
12249 {$IFDEF ShowCacheDependencies}
12250 DebugLn('[TFindDeclarationTool.ClearDependentNodeCaches] ',MainFilename);
12251 {$ENDIF}
12252 try
12253 ANode:=FDependentCodeTools.FindLowest;
12254 while ANode<>nil do begin
12255 DependentTool:=TFindDeclarationTool(ANode.Data);
12256 DependentTool.ClearNodeCaches;
12257 ANode:=FDependentCodeTools.FindSuccessor(ANode);
12258 end;
12259 FDependentCodeTools.Clear;
12260 finally
12261 FClearingDependentNodeCaches:=false;
12262 end;
12263 end;
12264
12265 procedure TFindDeclarationTool.ClearDependsOnToolRelationships;
12266 var
12267 ANode: TAVLTreeNode;
12268 DependOnTool: TFindDeclarationTool;
12269 begin
12270 if (FDependsOnCodeTools=nil) or (FDependsOnCodeTools.Count=0) then exit;
12271 {$IFDEF ShowCacheDependencies}
12272 DebugLn('[TFindDeclarationTool.ClearDependsOnToolRelationships] ',MainFilename);
12273 {$ENDIF}
12274 ANode:=FDependsOnCodeTools.FindLowest;
12275 while ANode<>nil do begin
12276 DependOnTool:=TFindDeclarationTool(ANode.Data);
12277 if not DependOnTool.FClearingDependentNodeCaches then
12278 DependOnTool.FDependentCodeTools.Remove(Self);
12279 ANode:=FDependsOnCodeTools.FindSuccessor(ANode);
12280 end;
12281 FDependsOnCodeTools.Clear;
12282 end;
12283
12284 procedure TFindDeclarationTool.AddToolDependency(
12285 DependOnTool: TFindDeclarationTool);
12286 // build a relationship: this tool depends on DependOnTool
12287 {$IFDEF DebugAddToolDependency}
12288 var
12289 AVLNode: TAVLTreeNode;
12290 Tool: TFindDeclarationTool;
12291 {$ENDIF}
12292 begin
12293 {$IFDEF ShowCacheDependencies}
12294 DebugLn('[TFindDeclarationTool.AddToolDependency] "',MainFilename,'" depends on "',DependOnTool.MainFilename,'"');
12295 {$ENDIF}
12296 if DependOnTool.FDependentCodeTools=nil then
12297 DependOnTool.FDependentCodeTools:=TAVLTree.Create;
12298 if DependOnTool.FDependentCodeTools.Find(Self)=nil then
12299 DependOnTool.FDependentCodeTools.Add(Self);
12300
12301 if FDependsOnCodeTools=nil then
12302 FDependsOnCodeTools:=TAVLTree.Create;
12303
12304 if FDependsOnCodeTools.Find(DependOnTool)=nil then begin
12305 {$IFDEF DebugAddToolDependency}
12306 AVLNode:=FDependsOnCodeTools.FindLowest;
12307 while AVLNode<>nil do begin
12308 Tool:=TFindDeclarationTool(AVLNode.Data);
12309 if CompareFilenames(ExtractFilename(Tool.MainFilename),ExtractFilename(DependOnTool.MainFilename))=0 then begin
12310 DebugLn(['TFindDeclarationTool.AddToolDependency inconsistency: ',Tool.MainFilename,' ',DependOnTool.MainFilename]);
12311 end;
12312 AVLNode:=FDependsOnCodeTools.FindSuccessor(AVLNode);
12313 end;
12314 {$ENDIF}
12315
12316 FDependsOnCodeTools.Add(DependOnTool);
12317 end;
12318 end;
12319
12320 procedure TFindDeclarationTool.ConsistencyCheck;
12321 var ANodeCache: TCodeTreeNodeCache;
12322 begin
12323 inherited ConsistencyCheck;
12324 if FInterfaceIdentifierCache<>nil then
12325 FInterfaceIdentifierCache.ConsistencyCheck;
12326 ANodeCache:=FFirstNodeCache;
12327 while ANodeCache<>nil do begin
12328 ANodeCache.ConsistencyCheck;
12329 ANodeCache:=ANodeCache.Next;
12330 end;
12331 if FDependentCodeTools<>nil then
12332 FDependentCodeTools.ConsistencyCheck;
12333 if FDependsOnCodeTools<>nil then
12334 FDependsOnCodeTools.ConsistencyCheck;
12335 end;
12336
12337 procedure TFindDeclarationTool.CalcMemSize(Stats: TCTMemStats);
12338 var
12339 NodeCache: TCodeTreeNodeCache;
12340 TypeCache: TBaseTypeCache;
12341 m: PtrUInt;
12342 HelperKind: TFDHelpersListKind;
12343 begin
12344 inherited CalcMemSize(Stats);
12345 if FInterfaceIdentifierCache<>nil then
12346 Stats.Add('TFindDeclarationTool.FInterfaceIdentifierCache',
12347 FInterfaceIdentifierCache.CalcMemSize);
12348 for HelperKind in TFDHelpersListKind do
12349 if FInterfaceHelperCache[HelperKind]<>nil then
12350 Stats.Add('TFindDeclarationTool.FInterfaceHelperCache[]',
12351 FInterfaceHelperCache[HelperKind].CalcMemSize);
12352 if FFirstNodeCache<>nil then begin
12353 m:=0;
12354 NodeCache:=FFirstNodeCache;
12355 while NodeCache<>nil do begin
12356 inc(m,NodeCache.CalcMemSize);
12357 NodeCache:=NodeCache.Next;
12358 end;
12359 Stats.Add('TFindDeclarationTool.NodeCache',m);
12360 end;
12361 if FFirstBaseTypeCache<>nil then begin
12362 m:=0;
12363 TypeCache:=FFirstBaseTypeCache;
12364 while TypeCache<>nil do begin
12365 inc(m,TypeCache.CalcMemSize);
12366 TypeCache:=TypeCache.NextCache;
12367 end;
12368 Stats.Add('TFindDeclarationTool.TypeCache',m);
12369 end;
12370 if FDependentCodeTools<>nil then
12371 Stats.Add('TFindDeclarationTool.FDependentCodeTools',
12372 FDependentCodeTools.Count*SizeOf(TAVLTreeNode));
12373 if FDependsOnCodeTools<>nil then
12374 Stats.Add('TFindDeclarationTool.FDependsOnCodeTools',
12375 FDependsOnCodeTools.Count*SizeOf(TAVLTreeNode));
12376 end;
12377
12378 procedure TFindDeclarationTool.ValidateToolDependencies;
12379 begin
12380 //debugln(['TFindDeclarationTool.ValidateToolDependencies ',MainFilename]);
12381 inherited ValidateToolDependencies;
12382 CheckDependsOnNodeCaches;
12383 end;
12384
GetNodeCachenull12385 function TFindDeclarationTool.GetNodeCache(Node: TCodeTreeNode;
12386 CreateIfNotExists: boolean): TCodeTreeNodeCache;
12387 begin
12388 {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF}
12389 while (Node<>nil) and (not (Node.Desc in AllNodeCacheDescs)) do
12390 Node:=Node.Parent;
12391 if Node<>nil then begin
12392 if (Node.Cache=nil) and CreateIfNotExists then
12393 CreateNewNodeCache(Node);
12394 if (Node.Cache is TCodeTreeNodeCache) then
12395 Result:=TCodeTreeNodeCache(Node.Cache)
12396 else
12397 Result:=nil;
12398 end else begin
12399 if (FRootNodeCache=nil) and CreateIfNotExists then
12400 FRootNodeCache:=CreateNewNodeCache(nil);
12401 Result:=FRootNodeCache;
12402 end;
12403 end;
12404
12405 procedure TFindDeclarationTool.AddResultToNodeCaches(
12406 StartNode, EndNode: TCodeTreeNode; SearchedForward: boolean;
12407 Params: TFindDeclarationParams; SearchRangeFlags: TNodeCacheEntryFlags);
12408 var Node: TCodeTreeNode;
12409 CurNodeCache, LastNodeCache: TCodeTreeNodeCache;
12410 CleanStartPos, CleanEndPos: integer;
12411 NewNode: TCodeTreeNode;
12412 NewTool: TPascalParserTool;
12413 NewCleanPos: integer;
12414 {$IFDEF ShowNodeCache}
12415 BeVerbose: boolean;
12416 NodeOwner: TObject;
12417
12418 function WriteSrcPos(t: TPascalParserTool; p: integer): string;
12419 begin
12420 Result:=StringToPascalConst(copy(t.Src,p-10,10)+'|'+copy(t.Src,p,15)+'"');
12421 end;
12422
12423 function NodeOwnerAsString(ANodeOwner: TObject): string;
12424 begin
12425 if ANodeOwner=nil then
12426 Result:='nil'
12427 else if ANodeOwner is TPascalParserTool then
12428 Result:=ExtractFileName(TPascalParserTool(ANodeOwner).MainFilename)
12429 else
12430 Result:='?'+ANodeOwner.ClassName+'?';
12431 end;
12432 {$ENDIF}
12433 begin
12434 {$IFDEF CheckNodeTool}CheckNodeTool(StartNode);{$ENDIF}
12435 if StartNode=nil then exit;
12436 if EndNode=nil then EndNode:=StartNode;
12437
12438 if Params.NewNode<>nil then begin
12439 // identifier found
12440 NewNode:=Params.NewNode;
12441 NewTool:=Params.NewCodeTool;
12442 NewCleanPos:=Params.NewCleanPos;
12443 end else begin
12444 // identifier not found
12445 NewNode:=nil;
12446 NewTool:=nil;
12447 NewCleanPos:=-1;
12448 end;
12449 // calculate search range
12450 if EndNode<>nil then begin
12451 if SearchedForward then begin
12452 CleanStartPos:=StartNode.StartPos;
12453 CleanEndPos:=EndNode.EndPos;
12454 end else begin
12455 CleanStartPos:=EndNode.StartPos;
12456 CleanEndPos:=StartNode.EndPos;
12457 end;
12458 end else begin
12459 // searched till start or end of source
12460 if not SearchedForward then begin
12461 CleanStartPos:=1;
12462 CleanEndPos:=StartNode.StartPos;
12463 end else begin
12464 CleanStartPos:=StartNode.StartPos;
12465 CleanEndPos:=SrcLen+1;
12466 end;
12467 end;
12468
12469 {$IFDEF ShowNodeCache}
12470 beVerbose:=true; //CompareSrcIdentifiers(Params.Identifier,'InitDecompressor');
12471 if beVerbose then begin
12472 DebugLn('(((((((((((((((((((((((((((==================');
12473
12474 DbgOut('TFindDeclarationTool.AddResultToNodeCaches ',
12475 ' Ident=',GetIdentifier(Params.Identifier));
12476 DbgOut(' SearchedForward=',DbgS(SearchedForward));
12477 DbgOut(' Flags=[');
12478 if ncefSearchedInParents in SearchRangeFlags then DbgOut('Parents');
12479 if ncefSearchedInAncestors in SearchRangeFlags then DbgOut(',Ancestors');
12480 DebugLn(']');
12481
12482 DbgOut(' StartNode=',StartNode.DescAsString,
12483 '('+DbgS(StartNode.StartPos),'-',DbgS(StartNode.EndPos)+')=',
12484 WriteSrcPos(Self,StartNode.StartPos));
12485 NodeOwner:=FindOwnerOfCodeTreeNode(StartNode);
12486 if NodeOwner<>Self then DbgOut(' StartNodeOwner=',NodeOwnerAsString(NodeOwner));
12487 DebugLn('');
12488
12489 if EndNode<>nil then
12490 DbgOut(' EndNode=',EndNode.DescAsString,
12491 '('+DbgS(EndNode.StartPos),'-',DbgS(EndNode.EndPos)+')=',
12492 WriteSrcPos(Self,EndNode.StartPos))
12493 else
12494 DbgOut(' EndNode=nil');
12495 NodeOwner:=FindOwnerOfCodeTreeNode(EndNode);
12496 if NodeOwner<>Self then DbgOut(' EndNodeOwner=',NodeOwnerAsString(NodeOwner));
12497 DebugLn('');
12498
12499 DebugLn(' Self=',ExtractFileName(MainFilename));
12500
12501 if NewNode<>nil then begin
12502 DebugLn(' NewNode=',NewNode.DescAsString,
12503 '(',DbgS(NewNode.StartPos),'-',DbgS(NewNode.EndPos),')=',
12504 WriteSrcPos(NewTool,NewNode.StartPos),
12505 ' NewTool=',ExtractFileName(NewTool.MainFilename));
12506 end else begin
12507 DebugLn(' NOT FOUND');
12508 //RaiseCatchableException('');
12509 end;
12510
12511 DebugLn(' CleanStartPos=',DbgS(CleanStartPos),' ',WriteSrcPos(Self,CleanStartPos));
12512 DebugLn(' CleanEndPos=',DbgS(CleanEndPos),' ',WriteSrcPos(Self,CleanEndPos));
12513 end;
12514 {$ENDIF}
12515 LastNodeCache:=nil;
12516 // start with parent of deepest node and end parent of highest
12517 Node:=StartNode;
12518 repeat
12519 if (Node.Desc in AllNodeCacheDescs) then begin
12520 if (Node.Cache=nil) then
12521 CreateNewNodeCache(Node);
12522 if (Node.Cache is TCodeTreeNodeCache) then begin
12523 CurNodeCache:=TCodeTreeNodeCache(Node.Cache);
12524 if LastNodeCache<>CurNodeCache then begin
12525 {$IFDEF ShowNodeCache}
12526 if BeVerbose then begin
12527 CurNodeCache.WriteDebugReport(' BEFORE NODECACHE REPORT: ');
12528 end;
12529 {$ENDIF}
12530 CurNodeCache.Add(Params.Identifier,
12531 Self,CleanStartPos,CleanEndPos,
12532 NewNode,NewTool,NewCleanPos,SearchRangeFlags);
12533 {$IFDEF ShowNodeCache}
12534 if BeVerbose then begin
12535 CurNodeCache.WriteDebugReport(' AFTER NODECACHE REPORT: ');
12536 end;
12537 {$ENDIF}
12538 LastNodeCache:=CurNodeCache;
12539 end;
12540 end;
12541 end;
12542 Node:=Node.Parent;
12543 until (Node=nil) or (EndNode=Node) or EndNode.HasAsParent(Node);
12544 {$IFDEF ShowNodeCache}
12545 if BeVerbose then begin
12546 DebugLn('=========================))))))))))))))))))))))))))))))))');
12547 end;
12548 {$ENDIF}
12549 end;
12550
CreateNewNodeCachenull12551 function TFindDeclarationTool.CreateNewNodeCache(
12552 Node: TCodeTreeNode): TCodeTreeNodeCache;
12553 begin
12554 {$IFDEF CheckNodeTool}CheckNodeTool(Node);{$ENDIF}
12555 Result:=NodeCacheMemManager.NewNodeCache(Node);
12556 Result.Next:=FFirstNodeCache;
12557 FFirstNodeCache:=Result;
12558 end;
12559
CreateNewBaseTypeCachenull12560 function TFindDeclarationTool.CreateNewBaseTypeCache(
12561 Tool: TFindDeclarationTool; Node: TCodeTreeNode): TBaseTypeCache;
12562 begin
12563 {$IFDEF CheckNodeTool}Tool.CheckNodeTool(Node);{$ENDIF}
12564 Result:=BaseTypeCacheMemManager.NewBaseTypeCache(Node);
12565 Result.NextCache:=Tool.FFirstBaseTypeCache;
12566 Tool.FFirstBaseTypeCache:=Result;
12567 end;
12568
12569 procedure TFindDeclarationTool.CreateBaseTypeCaches(
12570 NodeStack: PCodeTreeNodeStack; const Result: TFindContext);
12571 var i: integer;
12572 Entry: PCodeTreeNodeStackEntry;
12573 BaseTypeCache: TBaseTypeCache;
12574 NextEntry: PCodeTreeNodeStackEntry;
12575 begin
12576 {$IFDEF ShowBaseTypeCache}
12577 DbgOut('[TFindDeclarationTool.CreateBaseTypeCaches] ',
12578 ' StackPtr=',DbgS(NodeStack^.StackPtr));
12579 DebugLn(' Self=',MainFilename);
12580 if Result.Node<>nil then
12581 DbgOut(' Result='+Result.Node.DescAsString,
12582 ' Start='+DbgS(Result.Node.StartPos),
12583 ' End='+DbgS(Result.Node.EndPos),
12584 ' "'+copy(Result.Tool.Src,Result.Node.StartPos,15)+'" ',Result.Tool.MainFilename)
12585 else
12586 DbgOut(' Result=nil');
12587 DebugLn('');
12588 {$ENDIF}
12589 for i:=0 to NodeStack^.StackPtr do begin
12590 Entry:=GetNodeStackEntry(NodeStack,i);
12591 if Entry^.Node.Cache=nil then begin
12592 {$IFDEF ShowBaseTypeCache}
12593 DebugLn(' i=',DbgS(i),' Node=',Entry^.Node.DescAsString,' "',copy(Entry^.Tool.Src,Entry^.Node.StartPos,15),'"');
12594 {$ENDIF}
12595 BaseTypeCache:=
12596 CreateNewBaseTypeCache(TFindDeclarationTool(Entry^.Tool),Entry^.Node);
12597 if BaseTypeCache<>nil then begin
12598 BaseTypeCache.BaseNode:=Result.Node;
12599 BaseTypeCache.BaseTool:=Result.Tool;
12600 if i<NodeStack^.StackPtr then begin
12601 NextEntry:=GetNodeStackEntry(NodeStack,i+1);
12602 BaseTypeCache.NextNode:=NextEntry^.Node;
12603 BaseTypeCache.NextTool:=NextEntry^.Tool;
12604 end else begin
12605 BaseTypeCache.NextNode:=Result.Node;
12606 BaseTypeCache.NextTool:=Result.Tool;
12607 end;
12608 end;
12609 end;
12610 end;
12611 end;
12612
GetExpressionTypeOfTypeIdentifiernull12613 function TFindDeclarationTool.GetExpressionTypeOfTypeIdentifier(
12614 Params: TFindDeclarationParams): TExpressionType;
12615 var
12616 OldFlags: TFindDeclarationFlags;
12617 begin
12618 OldFlags:=Params.Flags;
12619 if FindIdentifierInContext(Params) then begin
12620 Params.Flags:=OldFlags;
12621 Result:=Params.NewCodeTool.ConvertNodeToExpressionType(Params.NewNode,Params);
12622 end else begin
12623 // predefined identifier
12624 Params.Flags:=OldFlags;
12625 Result:=CleanExpressionType;
12626 Result.Desc:=PredefinedIdentToExprTypeDesc(Params.Identifier,Scanner.PascalCompiler);
12627 end;
12628 end;
12629
FindTermTypeAsStringnull12630 function TFindDeclarationTool.FindTermTypeAsString(TermPos: TAtomPosition;
12631 Params: TFindDeclarationParams;
12632 out ExprType: TExpressionType): string;
12633 var
12634 EdgedBracketsStartPos: integer;
12635 SetNode: TCodeTreeNode;
12636 SetTool: TFindDeclarationTool;
12637 AliasType: TFindContext;
12638 begin
12639 //debugln(['TFindDeclarationTool.FindTermTypeAsString START']);
12640 {$IFDEF CheckNodeTool}CheckNodeTool(Params.ContextNode);{$ENDIF}
12641 Result:='';
12642 AliasType:=CleanFindContext;
12643
12644 if IsTermEdgedBracket(TermPos,EdgedBracketsStartPos) then begin
12645 // check for constant sets: [enum]
12646 MoveCursorToCleanPos(EdgedBracketsStartPos);
12647 ReadNextAtom;
12648 ReadNextAtom;
12649 if CurPos.Flag=cafWord then begin
12650 {$IFDEF ShowExprEval}
12651 debugln(['TFindDeclarationTool.FindTermTypeAsString "[name" : check for enumeration type ...']);
12652 debugln(['TFindDeclarationTool.FindTermTypeAsString StartContext=',Params.ContextNode.DescAsString,'=',dbgstr(Src,Params.ContextNode.StartPos,15),'"']);
12653 {$ENDIF}
12654 ExprType:=FindExpressionResultType(Params,EdgedBracketsStartPos+1,-1);
12655 {$IFDEF ShowExprEval}
12656 debugln(['TFindDeclarationTool.FindTermTypeAsString "[name" : ',ExprTypeToString(ExprType)]);
12657 {$ENDIF}
12658 if (ExprType.Desc=xtContext)
12659 and (ExprType.Context.Node.Desc in [ctnEnumerationType,ctnEnumIdentifier])
12660 then begin
12661 SetTool:=ExprType.Context.Tool;
12662 SetNode:=SetTool.FindSetOfEnumerationType(ExprType.Context.Node);
12663 if SetNode<>nil then begin
12664 ExprType:=CleanExpressionType;
12665 ExprType.Desc:=xtContext;
12666 ExprType.SubDesc:=xtNone;
12667 ExprType.Context.Tool:=SetTool;
12668 ExprType.Context.Node:=SetNode;
12669 Result:=SetTool.ExtractDefinitionName(SetNode);
12670 exit;
12671 end;
12672 end;
12673 end;
12674 end;
12675
12676 // check if TermPos is @Name and a pointer (= ^Name) can be found
12677 if IsTermNamedPointer(TermPos,ExprType) then begin
12678 // pointer type
12679 end else begin
12680 ExprType:=CleanExpressionType;
12681 Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors,fdfSearchInHelpers,
12682 fdfTopLvlResolving,fdfFunctionResult,fdfIgnoreOperatorError]
12683 +Params.Flags*[fdfOverrideStringTypesWithFirstParamType];
12684 ExprType:=FindExpressionResultType(Params,TermPos.StartPos,TermPos.EndPos,
12685 @AliasType);
12686 end;
12687
12688 if AliasType.Node<>nil then begin
12689 ExprType:=CleanExpressionType;
12690 ExprType.Desc:=xtContext;
12691 ExprType.Context:=AliasType;
12692 end;
12693 Result:=FindExprTypeAsString(ExprType,TermPos.StartPos);
12694 end;
12695
FindForInTypeAsStringnull12696 function TFindDeclarationTool.FindForInTypeAsString(TermPos: TAtomPosition;
12697 CursorNode: TCodeTreeNode; Params: TFindDeclarationParams; out
12698 ExprType: TExpressionType): string;
12699
12700 procedure RaiseTermHasNoIterator(id: int64; TermExprType: TExpressionType);
12701 begin
12702 if TermPos.StartPos<1 then
12703 TermPos.StartPos:=1;
12704 MoveCursorToCleanPos(TermPos.StartPos);
12705 debugln(['TFindDeclarationTool.FindForInTypeAsString TermExprType=',ExprTypeToString(TermExprType)]);
12706 RaiseException(id,'Can not find an enumerator for '''+TrimCodeSpace(GetAtom(TermPos))+'''');
12707 end;
12708
12709 procedure ResolveExpr(SubExprType: TExpressionType);
12710 var
12711 AliasType: TFindContext;
12712 Node: TCodeTreeNode;
12713 begin
12714 {$IFDEF ShowForInEval}
12715 debugln([' ResolveExpr ',ExprTypeToString(SubExprType)]);
12716 {$ENDIF}
12717 // use default enumerators
12718 case SubExprType.Desc of
12719 xtContext:
12720 begin
12721 case SubExprType.Context.Node.Desc of
12722 ctnSpecialize, ctnClass, ctnRecordType,
12723 ctnClassHelper, ctnRecordHelper, ctnTypeHelper, ctnClassInterface:
12724 begin
12725 AliasType:=CleanFindContext;
12726 if not SubExprType.Context.Tool.FindEnumeratorOfClass(
12727 SubExprType.Context.Node,true,ExprType,@AliasType, Params)
12728 then
12729 RaiseTermHasNoIterator(20170421211210,SubExprType);
12730 if (ExprType.Desc = xtContext)
12731 and (ExprType.Context.Node.Desc = ctnGenericParameter) then begin
12732 Params.UpdateContexWithGenParamValue(ExprType.Context);
12733 end;
12734 Result:=FindExprTypeAsString(ExprType,TermPos.StartPos,@AliasType);
12735 end;
12736 ctnEnumerationType:
12737 begin
12738 Node:=SubExprType.Context.Node.Parent;
12739 if Node.Desc=ctnTypeDefinition then
12740 Result:=SubExprType.Context.Tool.ExtractIdentifier(Node.StartPos);
12741 end;
12742 ctnSetType:
12743 if SubExprType.Context.Tool.FindEnumerationTypeOfSetType(
12744 SubExprType.Context.Node,ExprType.Context)
12745 then begin
12746 ExprType.Desc:=xtContext;
12747 Result:=FindExprTypeAsString(ExprType,TermPos.StartPos);
12748 end;
12749 ctnRangedArrayType,ctnOpenArrayType:
12750 begin
12751 AliasType:=CleanFindContext;
12752 if SubExprType.Context.Tool.FindElementTypeOfArrayType(
12753 SubExprType.Context.Node,ExprType,@AliasType,Params)
12754 then begin
12755 Result:=FindExprTypeAsString(ExprType,TermPos.StartPos,@AliasType);
12756 end;
12757 end;
12758 else
12759 RaiseTermHasNoIterator(20170421211213,SubExprType);
12760 end;
12761 end;
12762 xtChar,
12763 xtSmallInt,
12764 xtShortInt,
12765 xtByte,
12766 xtWord,
12767 xtBoolean,
12768 xtByteBool,
12769 xtWordBool,
12770 xtLongBool,
12771 xtQWordBool,
12772 xtNativeInt,
12773 xtNativeUInt:
12774 Result:=ExpressionTypeDescNames[SubExprType.Desc];
12775 xtNone,
12776 xtWideChar,
12777 xtReal,
12778 xtSingle,
12779 xtDouble,
12780 xtExtended,
12781 xtCExtended,
12782 xtCurrency,
12783 xtComp,
12784 xtInt64,
12785 xtCardinal,
12786 xtQWord,
12787 xtPointer,
12788 xtFile,
12789 xtText,
12790 xtConstOrdInteger,
12791 xtConstReal,
12792 xtConstBoolean,
12793 xtLongint,
12794 xtLongWord,
12795 xtCompilerFunc,
12796 xtVariant,
12797 xtJSValue,
12798 xtNil:
12799 RaiseTermHasNoIterator(20170421211217,SubExprType);
12800 xtString,
12801 xtAnsiString,
12802 xtShortString,
12803 xtPChar,
12804 xtConstString:
12805 begin
12806 ExprType.Desc:=xtChar;
12807 Result:=ExpressionTypeDescNames[ExprType.Desc];
12808 end;
12809 xtWideString,
12810 xtUnicodeString:
12811 begin
12812 ExprType.Desc:=xtWideChar;
12813 Result:=ExpressionTypeDescNames[ExprType.Desc];
12814 end;
12815 xtConstSet:
12816 begin
12817 if SubExprType.Context.Node=nil then
12818 RaiseTermHasNoIterator(20170421211222,SubExprType);
12819 SubExprType:=SubExprType.Context.Tool.FindExpressionTypeOfConstSet(SubExprType.Context.Node);
12820 {$IFDEF ShowForInEval}
12821 debugln([' ResolveExpr ConstSet Element: ',ExprTypeToString(SubExprType)]);
12822 {$ENDIF}
12823 if SubExprType.Desc=xtConstSet then
12824 RaiseTermHasNoIterator(20170421211222,SubExprType);
12825 ResolveExpr(SubExprType);
12826 end;
12827 else
12828 DebugLn('TFindDeclarationTool.FindForInTypeAsString.ResolveExpr TermExprType=',
12829 ExprTypeToString(SubExprType));
12830 RaiseTermHasNoIterator(20170421211225,SubExprType);
12831 end;
12832 end;
12833
12834 var
12835 TermExprType: TExpressionType;
12836 OperatorExprType: TExpressionType;
12837 begin
12838 Result:='';
12839 ExprType:=CleanExpressionType;
12840 TermExprType:=CleanExpressionType;
12841 Params.ContextNode:=CursorNode;
12842 Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors,fdfSearchInHelpers,
12843 fdfTopLvlResolving,fdfFunctionResult];
12844 TermExprType:=FindExpressionResultType(Params,TermPos.StartPos,TermPos.EndPos);
12845
12846 {$IFDEF ShowForInEval}
12847 DebugLn('TFindDeclarationTool.FindForInTypeAsString TermExprType=',
12848 ExprTypeToString(TermExprType));
12849 {$ENDIF}
12850 // search operator enumerator
12851 if FindOperatorEnumerator(CursorNode,TermExprType,foeEnumeratorCurrentExprType,
12852 OperatorExprType)
12853 then begin
12854 {$IFDEF ShowForInEval}
12855 DebugLn(['TFindDeclarationTool.FindForInTypeAsString Operator=',ExprTypeToString(OperatorExprType)]);
12856 {$ENDIF}
12857 ExprType:=OperatorExprType;
12858 Result:=FindExprTypeAsString(ExprType,TermPos.StartPos);
12859 exit;
12860 end;
12861 // convert to string
12862 ResolveExpr(TermExprType);
12863
12864 {$IFDEF ShowExprEval}
12865 DebugLn('TFindDeclarationTool.FindForInTypeAsString Result=',Result);
12866 {$ENDIF}
12867 end;
12868
FindEnumeratorOfClassnull12869 function TFindDeclarationTool.FindEnumeratorOfClass(ClassNode: TCodeTreeNode;
12870 ExceptionOnNotFound: boolean; out ExprType: TExpressionType;
12871 AliasType: PFindContext; ParentParams: TFindDeclarationParams): boolean;
12872 var
12873 Params: TFindDeclarationParams;
12874 ClassTool: TFindDeclarationTool;
12875 ClassContext: TFindContext;
12876 ProcTool: TFindDeclarationTool;
12877 ProcNode: TCodeTreeNode;
12878 EnumeratorContext: TFindContext;
12879 PropTool: TFindDeclarationTool;
12880 PropNode: TCodeTreeNode;
12881 CurrentContext: TFindContext;
12882 begin
12883 Result:=false;
12884 if AliasType<>nil then
12885 AliasType^:=CleanFindContext;
12886 ExprType:=CleanExpressionType;
12887 Params:=TFindDeclarationParams.Create(ParentParams);
12888 try
12889 if ClassNode.Desc = ctnSpecialize then begin
12890 Params.ContextNode:=ClassNode;
12891 Params.Flags:=[fdfEnumIdentifier,fdfTopLvlResolving];
12892 ClassContext := FindBaseTypeOfNode(Params, ClassNode, AliasType);
12893 if (ClassContext.Node = nil)
12894 or not (ClassContext.Node.Desc in [ctnClass,ctnClassInterface,ctnRecordType]) then begin
12895 if ExceptionOnNotFound then begin
12896 MoveCursorToCleanPos(ClassNode.StartPos);
12897 RaiseExceptionFmt(20200505081501,ctsBaseTypeOfNotFound,[GetIdentifier(@Src[ClassNode.StartPos])]);
12898 end else
12899 exit;
12900 end;
12901 ClassTool := ClassContext.Tool;
12902 ClassNode := ClassContext.Node;
12903 end else begin
12904 ClassTool := Self;
12905 end;
12906 // search function 'GetEnumerator'
12907 Params.ContextNode:=ClassNode;
12908 Params.Flags:=[fdfSearchInAncestors,fdfSearchInHelpers];
12909 Params.SetIdentifier(Self,'GetEnumerator',nil);
12910 {$IFDEF ShowForInEval}
12911 DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass searching GetEnumerator for ',ExtractClassName(ClassNode,false),' ...']);
12912 {$ENDIF}
12913 if not ClassTool.FindIdentifierInContext(Params) then begin
12914 if ExceptionOnNotFound then begin
12915 MoveCursorToCleanPos(ClassNode.StartPos);
12916 RaiseException(20170421200638,ctsFunctionGetEnumeratorNotFoundInThisClass);
12917 end else begin
12918 {$IFDEF ShowForInEval}
12919 debugln(['TFindDeclarationTool.FindEnumeratorOfClass GetEnumerator not found for ',ExtractClassName(ClassNode,false)]);
12920 {$ENDIF}
12921 exit;
12922 end;
12923 end;
12924 ProcTool:=Params.NewCodeTool;
12925 ProcNode:=Params.NewNode;
12926 //DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass Proc']);
12927 if (ProcNode=nil) or (ProcNode.Desc<>ctnProcedure) then begin
12928 if ExceptionOnNotFound then begin
12929 MoveCursorToCleanPos(ClassNode.StartPos);
12930 RaiseException(20170421200640,ctsFunctionGetEnumeratorNotFoundInThisClass2);
12931 end else begin
12932 {$IFDEF ShowForInEval}
12933 debugln(['TFindDeclarationTool.FindEnumeratorOfClass GetEnumerator is not a proc, class=',ExtractClassName(ClassNode,false)]);
12934 {$ENDIF}
12935 exit;
12936 end;
12937 end;
12938 // search function type
12939 Params.Clear;
12940 Include(Params.Flags,fdfFunctionResult);
12941 EnumeratorContext:=ProcTool.FindBaseTypeOfNode(Params,ProcNode);
12942 {$IFDEF ShowForInEval}
12943 DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass EnumeratorContext=',FindContextToString(EnumeratorContext)]);
12944 {$ENDIF}
12945 if (EnumeratorContext.Node=nil)
12946 or not (EnumeratorContext.Node.Desc in [ctnClass,ctnClassInterface,ctnRecordType])
12947 then begin
12948 if ExceptionOnNotFound then begin
12949 ProcTool.MoveCursorToCleanPos(ProcNode.StartPos);
12950 ProcTool.RaiseException(20170421200642,ctsResultTypeOfFunctionGetEnumeratorNotFound);
12951 end else
12952 exit;
12953 end;
12954 // search 'Current' in enumerator class
12955 Params.Clear;
12956 Params.ContextNode:=EnumeratorContext.Node;
12957 Params.Flags:=[fdfSearchInAncestors];
12958 if ExceptionOnNotFound then
12959 Include(Params.Flags,fdfExceptionOnNotFound);
12960 Params.SetIdentifier(EnumeratorContext.Tool,'Current',nil);
12961 //DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass search current ...']);
12962 if not EnumeratorContext.Tool.FindIdentifierInContext(Params) then begin
12963 {$IFDEF ShowForInEval}
12964 DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass missing "current" in ',EnumeratorContext.Tool.ExtractClassName(EnumeratorContext.Node,false)]);
12965 {$ENDIF}
12966 exit;
12967 end;
12968 // check if "current" is a property
12969 PropTool:=Params.NewCodeTool;
12970 PropNode:=Params.NewNode;
12971 //DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass PropNode=',PropNode.DescAsString]);
12972 if (PropNode=nil) or (PropNode.Desc<>ctnProperty) then begin
12973 if ExceptionOnNotFound then begin
12974 EnumeratorContext.Tool.MoveCursorToCleanPos(EnumeratorContext.Node.StartPos);
12975 RaiseException(20170421200644,ctsPropertyCurrentNotFound);
12976 end else begin
12977 {$IFDEF ShowForInEval}
12978 DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass "current" is not a property']);
12979 {$ENDIF}
12980 exit;
12981 end;
12982 end;
12983 // search type of Current
12984 Params.Clear;
12985 if ExceptionOnNotFound then
12986 Include(Params.Flags,fdfExceptionOnNotFound);
12987 //DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass searching property type ...']);
12988 CurrentContext:=PropTool.FindBaseTypeOfNode(Params,PropNode,AliasType);
12989 ExprType:=CurrentContext.Tool.ConvertNodeToExpressionType(
12990 CurrentContext.Node,Params,AliasType);
12991 {$IFDEF ShowForInEval}
12992 DebugLn(['TFindDeclarationTool.FindEnumeratorOfClass exprtype of CURRENT: ExprType=',ExprTypeToString(ExprType),' Alias=',FindContextToString(AliasType)]);
12993 {$ENDIF}
12994 Result:=ExprType.Desc<>xtNone;
12995 finally
12996 Params.Free;
12997 end;
12998 end;
12999
FindOperatorEnumeratornull13000 function TFindDeclarationTool.FindOperatorEnumerator(Node: TCodeTreeNode;
13001 ExprType: TExpressionType; Need: TFindOperatorEnumerator; out
13002 ResultExprType: TExpressionType): boolean;
13003 // find a compatible operator overload for 'enumerator' with a parameter
13004 // compatible to ExprType
13005 // for example:
13006 // operator enumerator (AList: TMyList): TMyListEnumerator;
13007 var
13008 Params: TFindDeclarationParams;
13009 OperatorTool: TFindDeclarationTool;
13010 OperatorNode: TCodeTreeNode;
13011 ClassContext: TFindContext;
13012 EnumeratorCurrentTool: TFindDeclarationTool;
13013 EnumeratorCurrentNode: TCodeTreeNode;
13014 begin
13015 Result:=false;
13016 ResultExprType:=CleanExpressionType;
13017 Params:=TFindDeclarationParams.Create;
13018 try
13019 // search compatible operator enumerator
13020 Params.ContextNode:=Node;
13021 Params.Flags:=[fdfSearchInParentNodes];
13022 Params.Data:=@ExprType;
13023 Params.SetIdentifier(Self,'Enumerator',@CheckOperatorEnumerator);
13024 {$IFDEF ShowForInEval}
13025 DebugLn(['TFindDeclarationTool.FindOperatorEnumerator searching operator enumerator ...']);
13026 {$ENDIF}
13027 if not FindIdentifierInContext(Params) then begin
13028 {$IFDEF ShowForInEval}
13029 DebugLn(['TFindDeclarationTool.FindOperatorEnumerator operator enumerator not found']);
13030 {$ENDIF}
13031 exit;
13032 end;
13033
13034 // operator found
13035 // now check if it is valid
13036 OperatorTool:=Params.NewCodeTool;
13037 OperatorNode:=Params.NewNode;
13038 {$IFDEF ShowForInEval}
13039 DebugLn(['TFindDeclarationTool.FindOperatorEnumerator Operator="',OperatorTool.ExtractNode(OperatorNode,[]),'"']);
13040 {$ENDIF}
13041 if Need=foeProcNode then begin
13042 ResultExprType.Desc:=xtContext;
13043 ResultExprType.Context.Tool:=OperatorTool;
13044 ResultExprType.Context.Node:=OperatorNode;
13045 exit(true);
13046 end;
13047
13048 // search class node
13049 Params.Clear;
13050 Params.Flags:=[fdfFunctionResult];
13051 {$IFDEF ShowForInEval}
13052 DebugLn(['TFindDeclarationTool.FindOperatorEnumerator searching operator result object ...']);
13053 {$ENDIF}
13054 ClassContext:=OperatorTool.FindBaseTypeOfNode(Params,OperatorNode);
13055 {$IFDEF ShowForInEval}
13056 DebugLn(['TFindDeclarationTool.FindOperatorEnumerator ClassContext=',FindContextToString(ClassContext)]);
13057 {$ENDIF}
13058 case ClassContext.Node.Desc of
13059 ctnClass,ctnObject,ctnRecordType,ctnClassInterface,ctnDispinterface: ;
13060 else
13061 OperatorTool.MoveCursorToNodeStart(OperatorNode);
13062 OperatorTool.RaiseException(20170421200650,'operator enumerator result type is not object');
13063 end;
13064 if Need=foeResultClassNode then begin
13065 ResultExprType.Desc:=xtContext;
13066 ResultExprType.Context:=ClassContext;
13067 exit(true);
13068 end;
13069
13070 // search property with modifier enumerator Current
13071 Params.Clear;
13072 Params.ContextNode:=ClassContext.Node;
13073 Params.Flags:=[fdfSearchInAncestors,fdfCollect];
13074 Params.SetIdentifier(Self,'',@CheckModifierEnumeratorCurrent);
13075 {$IFDEF ShowForInEval}
13076 DebugLn(['TFindDeclarationTool.FindOperatorEnumerator searching enumerator current ...']);
13077 {$ENDIF}
13078 if not ClassContext.Tool.FindIdentifierInContext(Params) then begin
13079 ClassContext.Tool.MoveCursorToNodeStart(ClassContext.Node);
13080 ClassContext.Tool.RaiseException(20170421200654,'enumerator ''current'' not found');
13081 end;
13082 EnumeratorCurrentTool:=Params.NewCodeTool;
13083 EnumeratorCurrentNode:=Params.NewNode;
13084 if Need=foeEnumeratorCurrentNode then begin
13085 ResultExprType.Desc:=xtContext;
13086 ResultExprType.Context.Tool:=EnumeratorCurrentTool;
13087 ResultExprType.Context.Node:=EnumeratorCurrentNode;
13088 exit(true);
13089 end;
13090
13091 // search expression type of 'enumerator current'
13092 Params.Clear;
13093 Params.Flags:=[fdfFunctionResult];
13094 {$IFDEF ShowForInEval}
13095 DebugLn(['TFindDeclarationTool.FindOperatorEnumerator searching enumerator current result ...']);
13096 {$ENDIF}
13097 ResultExprType:=EnumeratorCurrentTool.ConvertNodeToExpressionType(
13098 EnumeratorCurrentNode,Params);
13099 {$IFDEF ShowForInEval}
13100 DebugLn(['TFindDeclarationTool.FindOperatorEnumerator enumerator current result=',ExprTypeToString(ResultExprType)]);
13101 {$ENDIF}
13102 Result:=true;
13103 finally
13104 Params.Free;
13105 end;
13106 end;
13107
FindEnumerationTypeOfSetTypenull13108 function TFindDeclarationTool.FindEnumerationTypeOfSetType(
13109 SetTypeNode: TCodeTreeNode; out Context: TFindContext): boolean;
13110 var
13111 Params: TFindDeclarationParams;
13112 p: LongInt;
13113 begin
13114 Result:=false;
13115 if (SetTypeNode=nil) or (SetTypeNode.Desc<>ctnSetType) then exit;
13116 MoveCursorToNodeStart(SetTypeNode);
13117 ReadNextAtom; // set
13118 if not UpAtomIs('SET') then exit;
13119 ReadNextAtom; // of
13120 if not UpAtomIs('OF') then exit;
13121 ReadNextAtom;
13122 if not IsIdentStartChar[Src[CurPos.StartPos]] then
13123 // set of ()
13124 exit;
13125 Params:=TFindDeclarationParams.Create;
13126 try
13127 Params.Flags:=fdfDefaultForExpressions;
13128 Params.ContextNode:=SetTypeNode;
13129 p:=CurPos.StartPos;
13130 Params.SetIdentifier(Self,@Src[p],nil);
13131 if not FindIdentifierInContext(Params) then exit;
13132 if (Params.NewNode=nil)
13133 or (Params.NewNode.Desc<>ctnTypeDefinition)
13134 or (Params.NewNode.FirstChild=nil)
13135 or (Params.NewNode.FirstChild.Desc<>ctnEnumerationType) then begin
13136 MoveCursorToCleanPos(p);
13137 ReadNextAtom;
13138 RaiseStringExpectedButAtomFound(20170421200656,ctsEnumerationType);
13139 end;
13140 Context.Tool:=Params.NewCodeTool;
13141 Context.Node:=Params.NewNode;
13142 Result:=true;
13143 finally
13144 Params.Free;
13145 end;
13146 end;
13147
FindElementTypeOfArrayTypenull13148 function TFindDeclarationTool.FindElementTypeOfArrayType(
13149 ArrayNode: TCodeTreeNode; out ExprType: TExpressionType;
13150 AliasType: PFindContext; ParentParams: TFindDeclarationParams): boolean;
13151 var
13152 Params: TFindDeclarationParams;
13153 p: LongInt;
13154 begin
13155 Result:=false;
13156 ExprType:=CleanExpressionType;
13157 AliasType^:=CleanFindContext;
13158 if (ArrayNode=nil) then exit;
13159 if (ArrayNode.Desc<>ctnOpenArrayType) and (ArrayNode.Desc<>ctnRangedArrayType)
13160 then exit;
13161 if (ArrayNode.Parent <> nil)
13162 and (ArrayNode.Parent.Desc = ctnGenericType)
13163 and (ParentParams <> nil) then begin
13164 ExprType.Desc := xtContext;
13165 ExprType.Context.Node := ParentParams.GenParamValueMappings.SpecializeParamsNode.FirstChild;
13166 ExprType.Context.Tool := ParentParams.GenParamValueMappings.SpecializeParamsTool;
13167 Result:=true;
13168 end else begin
13169 MoveCursorToNodeStart(ArrayNode);
13170 ReadNextAtom; // array
13171 if not UpAtomIs('ARRAY') then exit;
13172 ReadNextAtom; // of
13173 if CurPos.Flag=cafEdgedBracketOpen then begin
13174 ReadTilBracketClose(true);
13175 ReadNextAtom;
13176 end;
13177 if not UpAtomIs('OF') then exit;
13178 ReadNextAtom;
13179 if not AtomIsIdentifier then exit;
13180 Params:=TFindDeclarationParams.Create;
13181 try
13182 Params.Flags:=fdfDefaultForExpressions;
13183 Params.ContextNode:=ArrayNode;
13184 p:=CurPos.StartPos;
13185 Params.SetIdentifier(Self,@Src[p],nil);
13186 ExprType:=FindExpressionResultType(Params,p,-1,AliasType);
13187 Result:=true;
13188 finally
13189 Params.Free;
13190 end;
13191 end;
13192 end;
13193
CheckOperatorEnumeratornull13194 function TFindDeclarationTool.CheckOperatorEnumerator(
13195 Params: TFindDeclarationParams; const FoundContext: TFindContext
13196 ): TIdentifierFoundResult;
13197 var
13198 Node: TCodeTreeNode;
13199 ExprType: TExpressionType;
13200 Params2: TFindDeclarationParams;
13201 begin
13202 Result:=ifrProceedSearch;
13203 {$IFDEF ShowExprEval}
13204 DebugLn(['TFindDeclarationTool.CheckOperatorEnumerator ',FindContextToString(FoundContext)]);
13205 {$ENDIF}
13206 if not FoundContext.Tool.NodeIsOperator(FoundContext.Node) then exit;
13207 FoundContext.Tool.BuildSubTreeForProcHead(FoundContext.Node);
13208 Node:=FoundContext.Node.FirstChild;
13209 if (Node=nil) or (Node.Desc<>ctnProcedureHead) then exit;
13210 Node:=Node.FirstChild;
13211 if (Node=nil) or (Node.Desc<>ctnParameterList) then exit;
13212 Node:=Node.FirstChild;
13213 if (Node=nil) then exit;
13214 if Node.NextBrother<>nil then exit;
13215 ExprType:=PExpressionType(Params.Data)^;
13216 Params2:=TFindDeclarationParams.Create;
13217 try
13218 if IsCompatible(Node,ExprType,Params2)=tcIncompatible then exit;
13219 finally
13220 Params2.Free;
13221 end;
13222 {$IFDEF ShowExprEval}
13223 DebugLn(['TFindDeclarationTool.CheckOperatorEnumerator FOUND ',FoundContext.Tool.ExtractNode(FoundContext.Node,[])]);
13224 {$ENDIF}
13225 Result:=ifrSuccess;
13226 end;
13227
CheckModifierEnumeratorCurrentnull13228 function TFindDeclarationTool.CheckModifierEnumeratorCurrent(
13229 Params: TFindDeclarationParams; const FoundContext: TFindContext
13230 ): TIdentifierFoundResult;
13231 begin
13232 Result:=ifrProceedSearch;
13233 //DebugLn(['TFindDeclarationTool.CheckModifierEnumeratorCurrent ',FindContextToString(FoundContext)]);
13234 case FoundContext.Node.Desc of
13235 ctnProperty:
13236 begin
13237 if FoundContext.Tool.PropertyHasSpecifier(FoundContext.Node,'Enumerator',false)
13238 then begin
13239 FoundContext.Tool.ReadNextAtom;
13240 if FoundContext.Tool.UpAtomIs('CURRENT') then
13241 Result:=ifrSuccess;
13242 end;
13243 end;
13244 end;
13245 end;
13246
IsTermEdgedBracketnull13247 function TFindDeclarationTool.IsTermEdgedBracket(TermPos: TAtomPosition; out
13248 EdgedBracketsStartPos: integer): boolean;
13249 { allowed:
13250 - at least one edged brackets
13251 - identifiers
13252 - functions
13253 - operators: + and -
13254
13255 [a,b]+[c]-D()*inherited E
13256
13257 not allowed:
13258 []<>[]
13259 }
13260 var
13261 Lvl: Integer;
13262 EndPos: LongInt;
13263 begin
13264 Result:=false;
13265 EdgedBracketsStartPos:=0;
13266 EndPos:=TermPos.EndPos;
13267 if EndPos>SrcLen then
13268 EndPos:=SrcLen;
13269 MoveCursorToCleanPos(TermPos.StartPos);
13270 Lvl:=0;
13271 repeat
13272 ReadNextAtom;
13273 if (CurPos.StartPos>=EndPos) then
13274 break;
13275 case CurPos.Flag of
13276 cafRoundBracketOpen: ReadTilBracketClose(false);
13277 cafEdgedBracketOpen:
13278 begin
13279 inc(Lvl);
13280 if (Lvl=1) and (EdgedBracketsStartPos<1) then begin
13281 if (not LastAtoms.HasPrior)
13282 or LastAtomIs(-1,'+') or LastAtomIs(-1,'-') or LastAtomIs(-1,'*')
13283 then
13284 EdgedBracketsStartPos:=CurPos.StartPos;
13285 end;
13286 end;
13287 cafEdgedBracketClose:
13288 dec(Lvl);
13289 cafWord:
13290 ;
13291 cafComma:
13292 if Lvl<1 then
13293 break
13294 else if Lvl>1 then
13295 exit;
13296 else
13297 if AtomIsChar('+') or AtomIsChar('-') then begin
13298 // allowed
13299 end else begin
13300 // not allowed
13301 exit;
13302 end;
13303 end;
13304 until false;
13305 Result:=EdgedBracketsStartPos>0;
13306 end;
13307
IsTermNamedPointernull13308 function TFindDeclarationTool.IsTermNamedPointer(TermPos: TAtomPosition; out
13309 ExprType: TExpressionType): boolean;
13310 // check if TermPos is @Name and a pointer (= ^Name) can be found
13311 var
13312 SubExprType: TExpressionType;
13313 Node: TCodeTreeNode;
13314 PointerTool: TFindDeclarationTool;
13315 Params: TFindDeclarationParams;
13316 PointerNode: TCodeTreeNode;
13317 begin
13318 //debugln(['TFindDeclarationTool.IsTermNamedPointer ',CleanPosToStr(TermPos.StartPos,true),' Term={',copy(Src,TermPos.StartPos,TermPos.EndPos-TermPos.StartPos),'}']);
13319 Result:=false;
13320 MoveCursorToCleanPos(TermPos.StartPos);
13321 ReadNextAtom;
13322 if not AtomIsChar('@') then exit;
13323 // a pointer
13324 ExprType:=CleanExpressionType;
13325 ExprType.Desc:=xtPointer;
13326 Result:=true;
13327 // try to find a name
13328 ReadNextAtom;
13329 if CurPos.StartPos>SrcLen then exit;
13330 Node := FindDeepestNodeAtPos(CurPos.StartPos,true);
13331 Params:=TFindDeclarationParams.Create(Self, Node);
13332 try
13333 SubExprType:=FindExpressionResultType(Params,CurPos.StartPos,-1);
13334 finally
13335 Params.Free;
13336 end;
13337 //debugln(['TFindDeclarationTool.IsTermNamedPointer SubExprType=',ExprTypeToString(SubExprType)]);
13338 if SubExprType.Desc in xtAllPredefinedTypes then begin
13339 ExprType.SubDesc:=SubExprType.Desc;
13340 exit(true);
13341 end else if (SubExprType.Desc=xtContext) then begin
13342 Node:=SubExprType.Context.Node;
13343 if (not (Node.Desc in AllIdentifierDefinitions))
13344 and (Node.Parent<>nil) and (Node.Parent.Desc in AllIdentifierDefinitions) then
13345 Node:=Node.Parent;
13346 if (Node.Desc in AllIdentifierDefinitions) then begin
13347 PointerTool:=SubExprType.Context.Tool;
13348 PointerNode:=PointerTool.FindPointerOfIdentifier(Node);
13349 if PointerNode<>nil then begin
13350 ExprType:=CleanExpressionType;
13351 ExprType.Desc:=xtContext;
13352 ExprType.SubDesc:=xtNone;
13353 ExprType.Context.Tool:=PointerTool;
13354 ExprType.Context.Node:=PointerNode;
13355 exit(true);
13356 end;
13357 end;
13358 end;
13359 end;
13360
FindSetOfEnumerationTypenull13361 function TFindDeclarationTool.FindSetOfEnumerationType(EnumNode: TCodeTreeNode
13362 ): TCodeTreeNode;
13363 // search in the same type section for a 'set of ' node
13364 var
13365 p: PChar;
13366
13367 function IsSetOfEnum(Node: TCodeTreeNode): boolean;
13368 begin
13369 Result:=false;
13370 if (Node.Desc<>ctnTypeDefinition)
13371 or (Node.FirstChild=nil)
13372 or (Node.FirstChild.Desc<>ctnSetType) then exit;
13373 MoveCursorToNodeStart(Node.FirstChild);
13374 ReadNextAtom; // read set
13375 if not UpAtomIs('SET') then exit;
13376 ReadNextAtom; // read of
13377 if not UpAtomIs('OF') then exit;
13378 ReadNextAtom; // read of
13379 if CurPos.Flag<>cafWord then exit;
13380 Result:=CompareSrcIdentifiers(CurPos.StartPos,p);
13381 end;
13382
13383 begin
13384 {$IFDEF ShowExprEval}
13385 debugln(['TFindDeclarationTool.FindSetOfEnumerationType ',EnumNode.DescAsString]);
13386 {$ENDIF}
13387 if EnumNode.Desc=ctnEnumIdentifier then EnumNode:=EnumNode.Parent;
13388 if EnumNode.Desc=ctnEnumerationType then EnumNode:=EnumNode.Parent;
13389 p:=@Src[EnumNode.StartPos];
13390 Result:=EnumNode.Parent.FirstChild;
13391 while Result<>nil do begin
13392 if IsSetOfEnum(Result) then exit;
13393 Result:=Result.NextBrother;
13394 end;
13395 end;
13396
FindPointerOfIdentifiernull13397 function TFindDeclarationTool.FindPointerOfIdentifier(
13398 TypeNode: TCodeTreeNode): TCodeTreeNode;
13399 // search in the same type section for a '^identifier' node
13400 var
13401 p: PChar;
13402
13403 function IsPointerOf(Node: TCodeTreeNode): boolean;
13404 begin
13405 Result:=false;
13406 if (Node.Desc<>ctnTypeDefinition)
13407 or (Node.FirstChild=nil)
13408 or (Node.FirstChild.Desc<>ctnPointerType) then exit;
13409 MoveCursorToNodeStart(Node.FirstChild);
13410 ReadNextAtom; // read ^
13411 if not AtomIsChar('^') then exit;
13412 ReadNextAtom; // read identifier
13413 if not AtomIsIdentifier then exit;
13414 Result:=CompareSrcIdentifiers(CurPos.StartPos,p);
13415 end;
13416
13417 begin
13418 if TypeNode.Desc<>ctnTypeDefinition then exit(nil);
13419 p:=@Src[TypeNode.StartPos];
13420 Result:=TypeNode.Parent.FirstChild;
13421 while Result<>nil do begin
13422 if IsPointerOf(Result) then exit;
13423 Result:=Result.NextBrother;
13424 end;
13425 end;
13426
FindExprTypeAsStringnull13427 function TFindDeclarationTool.FindExprTypeAsString(
13428 const ExprType: TExpressionType; TermCleanPos: integer;
13429 AliasType: PFindContext): string;
13430
13431 procedure RaiseTermNotSimple(id: int64);
13432 begin
13433 if TermCleanPos<1 then
13434 TermCleanPos:=1;
13435 MoveCursorToCleanPos(TermCleanPos);
13436 RaiseException(id,ctsTermNotSimple);
13437 end;
13438
13439 var
13440 FindContext: TFindContext;
13441 ANode: TCodeTreeNode;
13442 begin
13443 {$IFDEF ShowExprEval}
13444 DebugLn('TFindDeclarationTool.FindExprTypeAsString ExprType=',
13445 ExprTypeToString(ExprType),' Alias=',FindContextToString(AliasType));
13446 {$ENDIF}
13447 Result:='';
13448 if (AliasType<>nil) and (AliasType^.Node<>nil) then begin
13449 case AliasType^.Node.Desc of
13450 ctnTypeDefinition:
13451 Result:=GetIdentifier(@AliasType^.Tool.Src[AliasType^.Node.StartPos]);
13452 end;
13453 if Result<>'' then exit;
13454 end;
13455
13456 case ExprType.Desc of
13457 xtNone:
13458 RaiseTermNotSimple(20170421204649);
13459
13460 xtContext:
13461 begin
13462 FindContext:=ExprType.Context;
13463
13464 // ToDo: PPU, DCU
13465
13466 if FindContext.Node.Parent.Desc=ctnTypeDefinition then
13467 FindContext.Node:=FindContext.Node.Parent;
13468 case FindContext.Node.Desc of
13469
13470 ctnTypeDefinition:
13471 Result:=GetIdentifier(
13472 @FindContext.Tool.Src[FindContext.Node.StartPos]);
13473
13474 ctnVarDefinition,ctnConstDefinition:
13475 begin
13476 ANode:=FindContext.Tool.FindTypeNodeOfDefinition(FindContext.Node);
13477 if (ANode=nil) or (ANode.Desc<>ctnIdentifier) then
13478 RaiseTermNotSimple(20170421204653);
13479 Result:=GetIdentifier(@FindContext.Tool.Src[ANode.StartPos]);
13480 end;
13481
13482 ctnClass, ctnClassInterface, ctnDispinterface, ctnObject, ctnRecordType,
13483 ctnClassHelper, ctnRecordHelper, ctnTypeHelper,
13484 ctnObjCClass, ctnObjCCategory, ctnObjCProtocol, ctnCPPClass:
13485 if (FindContext.Node.Parent<>nil)
13486 and (FindContext.Node.Parent.Desc in [ctnTypeDefinition,ctnGenericType])
13487 then
13488 Result:=GetIdentifier(
13489 @FindContext.Tool.Src[FindContext.Node.Parent.StartPos]);
13490
13491 ctnEnumIdentifier:
13492 if (FindContext.Node.Parent<>nil)
13493 and (FindContext.Node.Parent.Desc=ctnEnumerationType)
13494 and (FindContext.Node.Parent.Parent<>nil)
13495 and (FindContext.Node.Parent.Parent.Desc=ctnTypeDefinition)
13496 then
13497 Result:=GetIdentifier(
13498 @FindContext.Tool.Src[FindContext.Node.Parent.Parent.StartPos]);
13499
13500 ctnEnumerationType:
13501 if (FindContext.Node.Parent<>nil)
13502 and (FindContext.Node.Parent.Desc=ctnTypeDefinition)
13503 then
13504 Result:=GetIdentifier(
13505 @FindContext.Tool.Src[FindContext.Node.Parent.StartPos]);
13506
13507 ctnProperty,ctnGlobalProperty:
13508 begin
13509 FindContext.Tool.MoveCursorToPropType(FindContext.Node);
13510 Result:=FindContext.Tool.GetAtom;
13511 end;
13512
13513 ctnIdentifier:
13514 begin
13515 Result:=GetIdentifier(
13516 @FindContext.Tool.Src[FindContext.Node.StartPos]);
13517 end;
13518
13519 ctnProcedureHead:
13520 begin
13521 ANode:=GetProcResultNode(FindContext.Node);
13522 if ANode<>nil then
13523 Result:=FindContext.Tool.ExtractNode(ANode,[]);
13524 end;
13525
13526 end;
13527
13528 if Result='' then begin
13529 DebugLn('TFindDeclarationTool.FindExprTypeAsString ContextNode=',
13530 FindContext.Node.DescAsString,' ',dbgsFC(FindContext));
13531 RaiseTermNotSimple(20170421204655);
13532 end;
13533 end;
13534
13535 xtChar,
13536 xtWideChar,
13537 xtReal,
13538 xtSingle,
13539 xtDouble,
13540 xtExtended,
13541 xtCExtended,
13542 xtCurrency,
13543 xtComp,
13544 xtInt64,
13545 xtCardinal,
13546 xtQWord,
13547 xtPChar:
13548 Result:=ExpressionTypeDescNames[ExprType.Desc];
13549
13550 xtPointer:
13551 begin
13552 case ExprType.SubDesc of
13553 xtChar,
13554 xtWideChar,
13555 xtReal,
13556 xtSingle,
13557 xtDouble,
13558 xtExtended,
13559 xtCExtended,
13560 xtCurrency,
13561 xtComp,
13562 xtInt64,
13563 xtCardinal,
13564 xtQWord,
13565 xtBoolean,
13566 xtByteBool,
13567 xtWordBool,
13568 xtLongBool,
13569 xtQWordBool,
13570 xtString,
13571 xtAnsiString,
13572 xtShortString,
13573 xtWideString,
13574 xtUnicodeString,
13575 xtLongint,
13576 xtLongWord,
13577 xtWord,
13578 xtSmallInt,
13579 xtShortInt,
13580 xtByte,
13581 xtNativeInt,
13582 xtNativeUInt:
13583 Result:='P'+ExpressionTypeDescNames[ExprType.SubDesc];
13584 else
13585 Result:=ExpressionTypeDescNames[xtPointer];
13586 end;
13587 end;
13588
13589 xtFile,
13590 xtText,
13591 xtLongint,
13592 xtLongWord,
13593 xtSmallInt,
13594 xtWord,
13595 xtShortInt,
13596 xtByte,
13597 xtNativeInt,
13598 xtNativeUInt:
13599 Result:=ExpressionTypeDescNames[ExprType.Desc];
13600
13601 xtBoolean,
13602 xtByteBool,
13603 xtWordBool,
13604 xtLongBool,
13605 xtQWordBool:
13606 Result:=ExpressionTypeDescNames[xtBoolean];
13607
13608 xtString,
13609 xtAnsiString,
13610 xtShortString:
13611 Result:=ExpressionTypeDescNames[xtString];
13612
13613 xtWideString, xtUnicodeString:
13614 Result:=ExpressionTypeDescNames[ExprType.Desc];
13615
13616 xtConstOrdInteger:
13617 Result:='Integer';
13618 xtConstString:
13619 Result:=ExpressionTypeDescNames[xtString];
13620 xtConstReal:
13621 Result:=ExpressionTypeDescNames[xtExtended];
13622 xtConstSet:
13623 begin
13624 // eventually try to find the 'set of ' type
13625 RaiseTermNotSimple(20170421204658);
13626 end;
13627 xtConstBoolean:
13628 Result:=ExpressionTypeDescNames[xtBoolean];
13629 xtJSValue:
13630 Result:=ExpressionTypeDescNames[ExprType.Desc];
13631 xtNil:
13632 RaiseTermNotSimple(20170421204702);
13633 else
13634 DebugLn('TCodeCompletionCodeTool.FindExprTypeAsString ExprType=',
13635 ExprTypeToString(ExprType),' Alias=',FindContextToString(AliasType));
13636 RaiseTermNotSimple(20170421204705);
13637 end;
13638 end;
13639
FindExtendedExprOfHelpernull13640 function TFindDeclarationTool.FindExtendedExprOfHelper(HelperNode: TCodeTreeNode
13641 ): TExpressionType;
13642 // returns the expression type of the extended class/type of a "helper for"
13643 var
13644 ForNode: TCodeTreeNode;
13645 Params: TFindDeclarationParams;
13646 begin
13647 case HelperNode.Desc of
13648 ctnClassHelper,ctnRecordHelper,ctnTypeHelper:
13649 ForNode:=FindHelperForNode(HelperNode);
13650 ctnObjCCategory:
13651 ForNode:=FindInheritanceNode(HelperNode);
13652 else
13653 exit(CleanExpressionType);
13654 end;
13655 if Assigned(ForNode) and Assigned(ForNode.FirstChild) then
13656 begin
13657 Params:=TFindDeclarationParams.Create;
13658 try
13659 Params.Flags:=fdfDefaultForExpressions-[fdfSearchInHelpers,fdfSearchInAncestors]+[fdfTypeType];
13660 Params.ContextNode:=ForNode;
13661 Result:=FindExpressionTypeOfTerm(ForNode.FirstChild.StartPos,ForNode.FirstChild.EndPos,Params,false);
13662 finally
13663 Params.Free;
13664 end;
13665 end else
13666 Result := CleanExpressionType;
13667 end;
13668
13669 { TFindDeclarationParams }
13670
13671 procedure TFindDeclarationParams.ClearFoundProc;
13672 begin
13673 if FoundProc=nil then exit;
13674 //DebugLn(['TFindDeclarationParams.ClearFoundProc ',dbgs(FoundProc),' Saved=',FoundProc^.Owner<>nil]);
13675 if FoundProc^.Owner=nil then
13676 // the FoundProc is not saved
13677 FreeFoundProc(FoundProc,true)
13678 else if FoundProc^.Next<>nil then
13679 // the FoundProc is saved (release the later FoundProcs,
13680 // which are not needed any more)
13681 FreeFoundProc(FoundProc^.Next,true)
13682 else begin
13683 // the FoundProc is owned, that means someo other function is reponsible for freeing it
13684 end;
13685 FoundProc:=nil;
13686 end;
13687
13688 procedure TFindDeclarationParams.FreeFoundProc(aFoundProc: PFoundProc; FreeNext: boolean);
13689 var
13690 Next: PFoundProc;
13691 begin
13692 //DebugLn(['TFindDeclarationParams.FreeFoundProc ',dbgs(aFoundProc)]);
13693 while aFoundProc<>nil do begin
13694 if (aFoundProc^.Owner<>Self)
13695 and ((FFoundProcStackFirst=aFoundProc)
13696 or (aFoundProc^.Prior<>nil) or (aFoundProc^.Next<>nil))
13697 then
13698 raise Exception.Create('FoundProc is in list, but not owned');
13699 if FreeNext then
13700 Next:=aFoundProc^.Next
13701 else
13702 Next:=nil;
13703 RemoveFoundProcFromList(aFoundProc);
13704 with aFoundProc^ do begin
13705 //DebugLn(['TFindDeclarationParams.FreeFoundProc ExprInputList=',dbgs(ExprInputList)]);
13706 if ExprInputList<>nil then
13707 FreeAndNil(ExprInputList);
13708 //DebugLn(['TFindDeclarationParams.FreeFoundProc ParamCompatibilityList=',dbgs(ParamCompatibilityList)]);
13709 if ParamCompatibilityList<>nil then begin
13710 FreeMem(ParamCompatibilityList);
13711 ParamCompatibilityList:=nil;
13712 end;
13713 CacheValid:=false;
13714 end;
13715 //DebugLn(['TFindDeclarationParams.FreeFoundProc Dispose ',dbgs(aFoundProc)]);
13716 Dispose(aFoundProc);
13717 aFoundProc:=Next;
13718 end;
13719 end;
13720
13721 procedure TFindDeclarationParams.RemoveFoundProcFromList(aFoundProc: PFoundProc);
13722 begin
13723 //DebugLn(['TFindDeclarationParams.RemoveFoundProcFromList ',dbgs(aFoundProc)]);
13724 if aFoundProc^.Owner<>Self then exit;
13725 if FFoundProcStackFirst=aFoundProc then
13726 FFoundProcStackFirst:=aFoundProc^.Next;
13727 if FFoundProcStackLast=aFoundProc then
13728 FFoundProcStackLast:=aFoundProc^.Next;
13729 with aFoundProc^ do begin
13730 if Next<>nil then
13731 Next^.Prior:=Prior;
13732 if Prior<>nil then
13733 Prior^.Next:=Next;
13734 Prior:=nil;
13735 Next:=nil;
13736 Owner:=nil;
13737 end;
13738 end;
13739
13740 constructor TFindDeclarationParams.Create(ParentParams: TFindDeclarationParams);
13741 begin
13742 inherited Create;
13743 Clear;
13744 Parent:=ParentParams;
13745 end;
13746
13747 constructor TFindDeclarationParams.Create(Tool: TFindDeclarationTool;
13748 AContextNode: TCodeTreeNode);
13749 begin
13750 Create(nil);//helper list will be created
13751 StartTool := Tool;
13752 StartNode := AContextNode;
13753 ContextNode := AContextNode;
13754 {$IFDEF CheckNodeTool}
13755 if (StartNode<>nil) and (StartNode.GetRoot<>StartTool.Tree.Root) then begin
13756 debugln(['TFindDeclarationParams.Create Inconsistency']);
13757 CTDumpStack;
13758 raise Exception.Create('TFindDeclarationParams.Create StartNode does not belong to StartTool');
13759 end;
13760 {$ENDIF}
13761 if (StartTool<>nil) and (StartNode<>nil) then
13762 FNeedHelpers:=true;
13763 end;
13764
13765 destructor TFindDeclarationParams.Destroy;
13766 var
13767 HelperKind: TFDHelpersListKind;
13768 begin
13769 Clear;
13770 FreeFoundProc(FFoundProcStackFirst,true);
13771 for HelperKind in TFDHelpersListKind do
13772 if FFreeHelpers[HelperKind] then
13773 FreeAndNil(FHelpers[HelperKind]);
13774 GenParamValueMappings.FirstParamValueMapping.Free;
13775 inherited Destroy;
13776 end;
13777
13778 procedure TFindDeclarationParams.Clear;
13779 begin
13780 ClearInput;
13781 ClearFoundProc;
13782 ClearResult(false);
13783 OnTopLvlIdentifierFound:=nil;
13784 end;
13785
13786 procedure TFindDeclarationParams.Save(out Input: TFindDeclarationInput);
13787 begin
13788 Input.Flags:=Flags;
13789 Input.Identifier:=Identifier;
13790 Input.ContextNode:=ContextNode;
13791 Input.OnIdentifierFound:=OnIdentifierFound;
13792 Input.IdentifierTool:=IdentifierTool;
13793 Input.FoundProc:=FoundProc;
13794 if (FoundProc<>nil) and (FoundProc^.Owner=nil) then begin
13795 // add to list of saved FoundProcs
13796 //DebugLn(['TFindDeclarationParams.Save ',dbgs(FoundProc)]);
13797 FoundProc^.Prior:=FFoundProcStackLast;
13798 if FFoundProcStackLast<>nil then
13799 FFoundProcStackLast^.Next:=FoundProc;
13800 FFoundProcStackLast:=FoundProc;
13801 if FFoundProcStackFirst=nil then
13802 FFoundProcStackFirst:=FoundProc;
13803 FoundProc^.Owner:=Self;
13804 end;
13805 end;
13806
13807 procedure TFindDeclarationParams.Load(Input: TFindDeclarationInput;
13808 FreeInput: boolean);
13809 // set FreeInput to true, if the Input is not needed anymore and the dynamic
13810 // data can be freed.
13811 begin
13812 Flags:=Input.Flags;
13813 Identifier:=Input.Identifier;
13814 ContextNode:=Input.ContextNode;
13815 OnIdentifierFound:=Input.OnIdentifierFound;
13816 IdentifierTool:=Input.IdentifierTool;
13817 if FoundProc<>Input.FoundProc then begin
13818 // clear current FoundProc
13819 if FoundProc<>nil then
13820 ClearFoundProc;
13821 // use saved FoundProc
13822 FoundProc:=Input.FoundProc;
13823 // free all FoundProcs, that were saved later
13824 if (FoundProc<>nil) then begin
13825 FreeFoundProc(FoundProc^.Next,true);
13826 if FreeInput then begin
13827 Input.FoundProc:=nil;
13828 RemoveFoundProcFromList(FoundProc);
13829 end;
13830 end;
13831 end;
13832 end;
13833
13834 procedure TFindDeclarationParams.ClearResult(CopyCacheFlags: boolean);
13835 begin
13836 NewPos.Code:=nil;
13837 NewPos.X:=-1;
13838 NewPos.Y:=-1;
13839 NewTopLine:=-1;
13840 NewNode:=nil;
13841 NewCleanPos:=-1;
13842 NewCodeTool:=nil;
13843 NewFlags:=[];
13844 if CopyCacheFlags and (fdfDoNotCache in Flags) then
13845 Include(NewFlags,fodDoNotCache);
13846 end;
13847
13848 procedure TFindDeclarationParams.SetResult(const AFindContext: TFindContext);
13849 begin
13850 ClearResult(true);
13851 NewCodeTool:=AFindContext.Tool;
13852 NewNode:=AFindContext.Node;
13853 end;
13854
13855 procedure TFindDeclarationParams.SetResult(ANewCodeTool: TFindDeclarationTool;
13856 ANewNode: TCodeTreeNode);
13857 begin
13858 ClearResult(true);
13859 NewCodeTool:=ANewCodeTool;
13860 NewNode:=ANewNode;
13861 {$IFDEF CheckNodeTool}if NewCodeTool<>nil then NewCodeTool.CheckNodeTool(NewNode);{$ENDIF}
13862 end;
13863
13864 procedure TFindDeclarationParams.SetResult(ANewCodeTool: TFindDeclarationTool;
13865 ANewNode: TCodeTreeNode; ANewCleanPos: integer);
13866 begin
13867 ClearResult(true);
13868 NewCodeTool:=ANewCodeTool;
13869 NewNode:=ANewNode;
13870 NewCleanPos:=ANewCleanPos;
13871 {$IFDEF CheckNodeTool}if NewCodeTool<>nil then NewCodeTool.CheckNodeTool(NewNode);{$ENDIF}
13872 end;
13873
13874 procedure TFindDeclarationParams.ConvertResultCleanPosToCaretPos;
13875 begin
13876 NewPos.Code:=nil;
13877 if NewCodeTool<>nil then begin
13878 if (NewCleanPos>=1) then
13879 NewCodeTool.CleanPosToCaretAndTopLine(NewCleanPos,NewPos,NewTopLine)
13880 else if (NewNode<>nil) then
13881 NewCodeTool.CleanPosToCaretAndTopLine(NewNode.StartPos,NewPos,NewTopLine);
13882 end;
13883 end;
13884
13885 procedure TFindDeclarationParams.ClearInput;
13886 begin
13887 Flags:=[];
13888 Identifier:=nil;
13889 ContextNode:=nil;
13890 OnIdentifierFound:=nil;
13891 IdentifierTool:=nil;
13892 end;
13893
13894 procedure TFindDeclarationParams.WriteDebugReport;
13895 begin
13896 DebugLn('TFindDeclarationParams.WriteDebugReport Self=',DbgS(Self));
13897
13898 // input parameters:
13899 DebugLn(' Flags=',dbgs(Flags));
13900 DebugLn(' Identifier=',GetIdentifier(Identifier));
13901 if ContextNode<>nil then
13902 DebugLn(' ContextNode=',ContextNode.DescAsString)
13903 else
13904 DebugLn(' ContextNode=nil');
13905 if OnIdentifierFound<>nil then
13906 DebugLn(' OnIdentifierFound=',TFindDeclarationTool(TMethod(OnIdentifierFound).Data).MainFilename);
13907 if IdentifierTool<>nil then
13908 DebugLn(' IdentifierTool=',IdentifierTool.MainFilename)
13909 else
13910 DebugLn(' IdentifierTool=nil');
13911 if FoundProc<>nil then begin
13912 if FoundProc^.Context.Node<>nil then
13913 DebugLn(' FoundProc=',FoundProc^.Context.Tool.CleanPosToStr(FoundProc^.Context.Node.StartPos,true))
13914 else
13915 DebugLn(' FoundProc<>nil');
13916 end;
13917
13918 // global params
13919 if OnTopLvlIdentifierFound<>nil then
13920 DebugLn(' OnTopLvlIdentifierFound=',TFindDeclarationTool(TMethod(OnTopLvlIdentifierFound).Code).MainFilename);
13921
13922 // results:
13923 if NewNode<>nil then
13924 DebugLn(' NewNode=',NewNode.DescAsString)
13925 else
13926 DebugLn(' NewNode=nil');
13927 DebugLn(' NewCleanPos=',dbgs(NewCleanPos));
13928 if NewCodeTool<>nil then begin
13929 DebugLn(' NewCodeTool=',NewCodeTool.MainFilename,' at ',NewCodeTool.CleanPosToStr(NewCleanPos,false))
13930 end else begin
13931 DebugLn([' NewCodeTool=nil NewCleanPos=',NewCleanPos]);
13932 end;
13933 if NewPos.Code<>nil then
13934 DebugLn([' NewPos=',NewPos.Code.Filename,' x=',NewPos.X,' y=',NewPos.Y,' topline=',NewTopLine])
13935 else
13936 DebugLn(' NewPos=nil');
13937 DebugLn(' NewFlags=',dbgs(NewFlags));
13938 DebugLn('');
13939 end;
13940
GetHelpersnull13941 function TFindDeclarationParams.GetHelpers(HelperKind: TFDHelpersListKind;
13942 CreateIfNotExists: boolean): TFDHelpersList;
13943 begin
13944 if Parent<>nil then
13945 exit(Parent.GetHelpers(HelperKind,CreateIfNotExists));
13946 if FNeedHelpers then
13947 StartTool.FindHelpersInContext(Self); // beware: this calls GetHelpers
13948 Result:=FHelpers[HelperKind];
13949 if (Result=nil) and CreateIfNotExists then begin
13950 Result:=TFDHelpersList.Create(HelperKind);
13951 FHelpers[HelperKind]:=Result;
13952 FFreeHelpers[HelperKind]:=true;
13953 //if HelperKind=fdhlkDelphiHelper then
13954 // debugln(['TFindDeclarationParams.GetHelpers Self=',dbgs(Pointer(Self)),' Helper=',dbgs(Pointer(FHelpers[HelperKind]))]);
13955 end;
13956 end;
13957
13958 procedure TFindDeclarationParams.SetIdentifier(
13959 NewIdentifierTool: TFindDeclarationTool; NewIdentifier: PChar;
13960 NewOnIdentifierFound: TOnIdentifierFound);
13961 begin
13962 Identifier:=NewIdentifier;
13963 IdentifierTool:=NewIdentifierTool;
13964 OnIdentifierFound:=NewOnIdentifierFound;
13965 ClearFoundProc;
13966 end;
13967
13968 procedure TFindDeclarationParams.SetFoundProc(
13969 const ProcContext: TFindContext);
13970 begin
13971 //DebugLn(['TFindDeclarationParams.SetFirstFoundProc Old=',dbgs(FoundProc)]);
13972 if FoundProc<>nil then
13973 ClearFoundProc;
13974 New(FoundProc);
13975 //DebugLn(['TFindDeclarationParams.SetFirstFoundProc New=',dbgs(FoundProc)]);
13976 FillChar(FoundProc^,SizeOf(TFoundProc),0);
13977 FoundProc^.Context:=ProcContext;
13978 end;
13979
13980 procedure TFindDeclarationParams.SetGenericParamValues(
13981 SpecializeParamsTool: TFindDeclarationTool;
13982 SpecializeNode: TCodeTreeNode);
13983 begin
13984 GenParams.ParamValuesTool := SpecializeParamsTool;
13985 GenParams.SpecializeParamsNode := SpecializeNode.FirstChild.NextBrother;
13986 end;
13987
13988 procedure TFindDeclarationParams.UpdateGenericParamMapping(SpecializeParamsTool: TFindDeclarationTool;
13989 SpecializeParamsNode: TCodeTreeNode; GenericParamsNode: TCodeTreeNode);
13990
13991 procedure ForwardParamMapping;
13992 var
13993 lGenericParamNode,
13994 lSpecializeParamNode,
13995 lGenericParamValueNode: TCodeTreeNode;
13996 lFirstMapping,
13997 lMapping,
13998 lLoopMapping: TGenericParamValueMapping;
13999 lFound: Boolean;
14000 begin
14001 lFirstMapping := nil;
14002 lMapping := nil;
14003 // GenericParams: GObject1<V1, V2> = class(GObject2<V2, V1>)
14004 // ^^^^^^
14005 // SpecializeParams: GObject1<V1, V2> = class(GObject2<V2, V1>)
14006 // ^^^^^^
14007 if GenParamValueMappings.FirstParamValueMapping = nil then begin
14008 // first mapping: values from GenParamValueMappings.SpecializeParamsNode
14009 lSpecializeParamNode := SpecializeParamsNode.FirstChild;
14010 while lSpecializeParamNode <> nil do begin
14011 //find generic param / generic param value
14012 lGenericParamNode := GenericParamsNode.FirstChild;
14013 lGenericParamValueNode := GenParamValueMappings.SpecializeParamsNode.FirstChild;
14014 lFound := false;
14015 while (lGenericParamNode <> nil)
14016 and (lGenericParamValueNode <> nil) do begin
14017 if SpecializeParamsTool.CompareSrcIdentifiers(lSpecializeParamNode.StartPos, lGenericParamNode.StartPos) then begin
14018 // found generic param
14019 lMapping := TGenericParamValueMapping.Create(lMapping, lSpecializeParamNode, lGenericParamValueNode);
14020 if lFirstMapping = nil then
14021 lFirstMapping := lMapping;
14022 lFound := true;
14023 break;
14024 end;
14025 lGenericParamNode := lGenericParamNode.NextBrother;
14026 lGenericParamValueNode := lGenericParamValueNode.NextBrother;
14027 end;
14028 if not lFound then begin
14029
14030 end;
14031 lSpecializeParamNode := lSpecializeParamNode.NextBrother;
14032 end;
14033 GenParamValueMappings.FirstParamValueMapping := lFirstMapping;
14034 GenParamValueMappings.SpecializeValuesTool := GenParamValueMappings.SpecializeParamsTool;
14035 end else begin
14036 // further mapping: values from GenParamValueMappings.FirstParamValueMapping
14037 lSpecializeParamNode := SpecializeParamsNode.FirstChild;
14038 while lSpecializeParamNode <> nil do begin
14039 //find generic param / generic param value
14040 lLoopMapping := GenParamValueMappings.FirstParamValueMapping;
14041 lGenericParamNode := GenericParamsNode.FirstChild;
14042 lFound := false;
14043 while (lLoopMapping <> nil) do begin
14044 lGenericParamValueNode := lLoopMapping.SpecializeValueNode;
14045 if SpecializeParamsTool.CompareSrcIdentifiers(lSpecializeParamNode.StartPos, lGenericParamNode.StartPos) then begin
14046 // found generic param
14047 lMapping := TGenericParamValueMapping.Create(lMapping, lSpecializeParamNode, lGenericParamValueNode);
14048 if lFirstMapping = nil then
14049 lFirstMapping := lMapping;
14050 lFound := true;
14051 break;
14052 end;
14053 lGenericParamNode := lGenericParamNode.NextBrother;
14054 lLoopMapping := lLoopMapping.NextBrother;
14055 end;
14056 if not lFound then begin
14057
14058 end;
14059 lSpecializeParamNode := lSpecializeParamNode.NextBrother;
14060 end;
14061 GenParamValueMappings.FirstParamValueMapping.Free;
14062 GenParamValueMappings.FirstParamValueMapping := lFirstMapping;
14063 end;
14064 end;
14065
14066 begin
14067 if Parent <> nil then begin
14068 Parent.UpdateGenericParamMapping(SpecializeParamsTool, SpecializeParamsNode, GenericParamsNode);
14069 exit;
14070 end;
14071 if (GenericParamsNode <> nil)
14072 and (GenParamValueMappings.SpecializeParamsNode <> nil) then
14073 ForwardParamMapping;
14074 GenParamValueMappings.SpecializeParamsTool := SpecializeParamsTool;
14075 GenParamValueMappings.SpecializeParamsNode := SpecializeParamsNode;
14076 end;
14077
14078 procedure TFindDeclarationParams.UpdateContexWithGenParamValue(var SpecializeParamContext: TFindContext);
14079 var
14080 lMapping: TGenericParamValueMapping;
14081 lPNode, lVNode: TCodeTreeNode;
14082 lPTool, lVTool: TFindDeclarationTool;
14083 begin
14084 lMapping := GenParamValueMappings.FirstParamValueMapping;
14085 while lMapping <> nil do begin
14086 lPNode := lMapping.GenericParamNode;
14087 lPTool := GenParamValueMappings.SpecializeParamsTool;
14088 lVNode := lMapping.SpecializeValueNode;
14089 lVTool := GenParamValueMappings.SpecializeValuesTool;
14090 if SpecializeParamContext.Tool.CompareSrcIdentifiers(SpecializeParamContext.Node.StartPos, @lPTool.Src[lPNode.StartPos]) then begin
14091 SpecializeParamContext.Node := lVNode;
14092 SpecializeParamContext.Tool := lVTool;
14093 exit;
14094 end;
14095 lMapping := lMapping.NextBrother;
14096 end;
14097 end;
14098
FindGenericParamTypenull14099 function TFindDeclarationParams.FindGenericParamType: Boolean;
14100 var
14101 i, n: integer;
14102 GenParamType: TCodeTreeNode;
14103 begin
14104 // NewCodeTool, NewNode=GenericParamType
14105 if not Assigned(NewCodeTool) or not Assigned(NewNode)
14106 or not Assigned(GenParams.ParamValuesTool)
14107 or not Assigned(GenParams.SpecializeParamsNode) then exit(false);
14108 n:=0;
14109 GenParamType:=NewNode;
14110 while GenParamType<>nil do begin
14111 GenParamType:=GenParamType.PriorBrother;
14112 inc(n);
14113 end;
14114 with GenParams.ParamValuesTool do begin
14115 MoveCursorToNodeStart(GenParams.SpecializeParamsNode);
14116 ReadNextAtom;
14117 // maybe all this syntax check is redundant
14118 if not AtomIsChar('<') then
14119 RaiseExceptionFmt(20170421200701,ctsStrExpectedButAtomFound,['<']);
14120 ReadNextAtom;
14121 if CurPos.Flag<>cafWord then
14122 RaiseExceptionFmt(20170421200703,ctsIdentExpectedButAtomFound,[GetAtom]);
14123 for i:=2 to n do begin
14124 ReadNextAtom;
14125 if AtomIsChar('>') then
14126 RaiseException(20170421200705,ctsNotEnoughGenParams);
14127 if not AtomIsChar(',') then
14128 RaiseExceptionFmt(20170421200707,ctsStrExpectedButAtomFound,['>']);
14129 ReadNextAtom;
14130 if CurPos.Flag<>cafWord then
14131 RaiseExceptionFmt(20170421200710,ctsIdentExpectedButAtomFound,[GetAtom]);
14132 end;
14133 Identifier:=@Src[CurPos.StartPos];
14134 IdentifierTool:=GenParams.ParamValuesTool;
14135 ContextNode:=GenParams.SpecializeParamsNode;
14136 Result:=FindIdentifierInContext(Self);
14137 end;
14138 end;
14139
14140 procedure TFindDeclarationParams.AddOperandPart(aPart: string);
14141 begin
14142 FExtractedOperand := FExtractedOperand + aPart;
14143 end;
14144
14145 procedure TFindDeclarationParams.ChangeFoundProc(
14146 const ProcContext: TFindContext;
14147 ProcCompatibility: TTypeCompatibility;
14148 ParamCompatibilityList: TTypeCompatibilityList);
14149 begin
14150 FoundProc^.Context:=ProcContext;
14151 FoundProc^.ProcCompatibility:=ProcCompatibility;
14152 if (FoundProc^.ParamCompatibilityList<>ParamCompatibilityList) then begin
14153 //DebugLn(['TFindDeclarationParams.ChangeFoundProc Old ParamCompatibilityList=',dbgs(FoundProc^.ParamCompatibilityList)]);
14154 if (FoundProc^.ParamCompatibilityList<>nil) then
14155 FreeMem(FoundProc^.ParamCompatibilityList);
14156 FoundProc^.ParamCompatibilityList:=ParamCompatibilityList;
14157 //DebugLn(['TFindDeclarationParams.ChangeFoundProc New ParamCompatibilityList=',dbgs(FoundProc^.ParamCompatibilityList)]);
14158 end;
14159 end;
14160
IsFoundProcFinalnull14161 function TFindDeclarationParams.IsFoundProcFinal: boolean;
14162 begin
14163 Result:=(FoundProc=nil)
14164 or (FoundProc^.CacheValid and (FoundProc^.ProcCompatibility=tcExact));
14165 end;
14166
14167 procedure TFindDeclarationParams.PrettifyResult;
14168 begin
14169 // adjust result for nicer position
14170 if (NewNode<>nil) then begin
14171 {$IFDEF CheckNodeTool}
14172 if NewCodeTool<>nil then
14173 NewCodeTool.CheckNodeTool(NewNode);
14174 {$ENDIF}
14175 case NewNode.Desc of
14176 ctnProcedure:
14177 if (NewNode.FirstChild<>nil)
14178 and (NewNode.FirstChild.Desc=ctnProcedureHead) then begin
14179 // Instead of jumping to the procedure keyword,
14180 // jump to the procedure name
14181 NewNode:=NewNode.FirstChild;
14182 NewCleanPos:=NewNode.StartPos;
14183 end;
14184 ctnGenericType:
14185 if (NewNode.FirstChild<>nil) then begin
14186 // Instead of jumping to the generic keyword,
14187 // jump to the name
14188 NewNode:=NewNode.FirstChild;
14189 NewCleanPos:=NewNode.StartPos;
14190 end;
14191 ctnProperty:
14192 // jump to the name of the property
14193 if NewCodeTool.MoveCursorToPropName(NewNode) then
14194 NewCleanPos:=NewCodeTool.CurPos.StartPos;
14195 end;
14196 end;
14197 end;
14198
14199 procedure TFindDeclarationParams.SetResult(
14200 NodeCacheEntry: PCodeTreeNodeCacheEntry);
14201 begin
14202 ClearResult(true);
14203 NewCodeTool:=TFindDeclarationTool(NodeCacheEntry^.NewTool);
14204 NewNode:=NodeCacheEntry^.NewNode;
14205 NewCleanPos:=NodeCacheEntry^.NewCleanPos;
14206 end;
14207
14208
14209 { TExprTypeList }
14210
14211 destructor TExprTypeList.Destroy;
14212 begin
14213 if Items<>nil then begin
14214 FreeMem(Items);
14215 Freemem(AliasTypes);
14216 end;
14217 end;
14218
AsStringnull14219 function TExprTypeList.AsString: string;
14220 var i: integer;
14221 begin
14222 Result:='';
14223 for i:=0 to Count-1 do begin
14224 Result:=Result+'{'+IntToStr(i)+'/'+IntToStr(Count)+':'+ExprTypeToString(Items[i])+'}'+LineEnding;
14225 end;
14226 end;
14227
CalcMemSizenull14228 function TExprTypeList.CalcMemSize: PtrUInt;
14229 begin
14230 Result:=PtrUInt(InstanceSize)
14231 +PtrUInt(FCapacity)*SizeOf(TExpressionType);
14232 end;
14233
14234 procedure TExprTypeList.SetCapacity(const AValue: integer);
14235 var NewSize, NewAliasSize: integer;
14236 begin
14237 if FCapacity=AValue then exit;
14238 FCapacity:=AValue;
14239 NewSize:=FCapacity*SizeOf(TExpressionType);
14240 NewAliasSize:=FCapacity*SizeOf(TFindContext);
14241 if Items=nil then begin
14242 GetMem(Items,NewSize);
14243 GetMem(AliasTypes,NewAliasSize);
14244 end
14245 else begin
14246 ReAllocMem(Items,NewSize);
14247 ReAllocMem(AliasTypes,NewAliasSize);
14248 end;
14249 if Count>Capacity then Count:=Capacity;
14250 end;
14251
14252 procedure TExprTypeList.Grow;
14253 begin
14254 Capacity:=Capacity*2+4;
14255 end;
14256
14257 procedure TExprTypeList.Add(const ExprType: TExpressionType);
14258 begin
14259 inc(Count);
14260 if Count>Capacity then Grow;
14261 Items[Count-1]:=ExprType;
14262 AliasTypes[Count-1]:=CleanFindContext;
14263 end;
14264
14265 procedure TExprTypeList.Add(const ExprType: TExpressionType;
14266 const AliasType: TFindContext);
14267 begin
14268 inc(Count);
14269 if Count>Capacity then Grow;
14270 Items[Count-1]:=ExprType;
14271 AliasTypes[Count-1]:=AliasType;
14272 end;
14273
14274 procedure TExprTypeList.AddFirst(const ExprType: TExpressionType);
14275 begin
14276 inc(Count);
14277 if Count>Capacity then Grow;
14278 if Count>1 then
14279 Move(Items[0],Items[1],SizeOf(TExpressionType)*(Count-1));
14280 Items[0]:=ExprType;
14281 end;
14282
14283
14284 finalization
14285 FreeAndNil(FBooleanTypesOrderList);
14286 FreeAndNil(FIntegerTypesOrderList);
14287 FreeAndNil(FRealTypesOrderList);
14288 FreeAndNil(FStringTypesOrderList);
14289
14290 end.
14291
14292