/components/codetools/pascalreadertool.pas
Pascal | 3764 lines | 3238 code | 237 blank | 289 comment | 762 complexity | 9588f51c2b0af8cf12bed6b33ebc8a5b MD5 | raw file
Large files files are truncated, but you can click here to view the full file
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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. * 18 * * 19 *************************************************************************** 20 21 Author: Mattias Gaertner 22 23 Abstract: 24 TPascalReaderTool enhances TPascalParserTool. 25 This tool provides a lot of useful functions to read the output of the 26 TPascalParserTool. 27} 28unit PascalReaderTool; 29 30{$ifdef FPC}{$mode objfpc}{$endif}{$H+} 31 32interface 33 34{$I codetools.inc} 35 36uses 37 {$IFDEF MEM_CHECK} 38 MemCheck, 39 {$ENDIF} 40 Classes, SysUtils, FileProcs, CodeToolsStrConsts, CodeTree, CodeCache, 41 CodeAtom, CustomCodeTool, PascalParserTool, KeywordFuncLists, BasicCodeTools, 42 LinkScanner, AVL_Tree, LazFileUtils, LazDbgLog; 43 44type 45 TPascalHintModifier = ( 46 phmDeprecated, 47 phmPlatform, 48 phmLibrary, 49 phmUnimplemented, 50 phmExperimental 51 ); 52 TPascalHintModifiers = set of TPascalHintModifier; 53 54 TEPRIRange = ( 55 epriInCode, 56 epriInComment, 57 epriInDirective 58 ); 59 60 //the scope groups of pascal methods. 61 //please note that Destructor is principally a method and thus is not listed here -> you cannot define "procedure Destroy;" and "destructor Destroy" in one class 62 TPascalMethodGroup = (mgMethod, mgConstructor, mgClassConstructor, mgClassDestructor, mgClassOperator); 63 64 TPascalMethodHeader = record 65 Name, ResultType: string; 66 Group: TPascalMethodGroup; 67 end; 68 69 TClassSectionVisibility = ( 70 csvEverything,//same class same unit 71 csvPrivateAndHigher,//same unit different class 72 csvProtectedAndHigher,//ancestor class different unit 73 csvPublicAndHigher);//other class other unit 74 75 TOnEachPRIdentifier = procedure(Sender: TPascalParserTool; 76 IdentifierCleanPos: integer; Range: TEPRIRange; 77 Node: TCodeTreeNode; Data: Pointer; var Abort: boolean) of object; 78 79 { TPascalReaderTool } 80 81 TPascalReaderTool = class(TPascalParserTool) 82 protected 83 CachedSourceName: string; 84 procedure RaiseStrConstExpected; 85 public 86 // comments 87 function CleanPosIsInComment(CleanPos, CleanCodePosInFront: integer; 88 out CommentStart, CommentEnd: integer; 89 OuterCommentBounds: boolean = true): boolean; 90 91 // general extraction 92 function ExtractNode(ANode: TCodeTreeNode; 93 Attr: TProcHeadAttributes): string; 94 function ExtractCode(StartPos, EndPos: integer; 95 Attr: TProcHeadAttributes): string; 96 function ExtractBrackets(BracketStartPos: integer; 97 Attr: TProcHeadAttributes): string; 98 function ExtractIdentifierWithPoints(StartPos: integer; 99 ExceptionOnError: boolean): string; 100 function ExtractIdentCharsFromStringConstant( 101 StartPos, MinPos, MaxPos, MaxLen: integer): string; 102 function ReadStringConstantValue(StartPos: integer): string; 103 function GetNodeIdentifier(Node: TCodeTreeNode): PChar; 104 function GetHintModifiers(Node: TCodeTreeNode): TPascalHintModifiers; 105 procedure ForEachIdentifierInCleanSrc(StartPos, EndPos: integer; 106 SkipComments: boolean; Node: TCodeTreeNode; 107 const OnIdentifier: TOnEachPRIdentifier; Data: pointer; 108 var Abort: boolean); // range in clean source 109 procedure ForEachIdentifierInNode(Node: TCodeTreeNode; SkipComments: boolean; 110 const OnIdentifier: TOnEachPRIdentifier; Data: Pointer; var Abort: boolean); // node and child nodes 111 procedure ForEachIdentifier(SkipComments: boolean; 112 const OnIdentifier: TOnEachPRIdentifier; Data: Pointer); // whole unit/program 113 114 // properties 115 function ExtractPropType(PropNode: TCodeTreeNode; 116 InUpperCase, EmptyIfIndexed: boolean): string; 117 function MoveCursorToPropType(PropNode: TCodeTreeNode): boolean; 118 function MoveCursorToPropName(PropNode: TCodeTreeNode): boolean; 119 procedure MoveCursorBehindPropName(PropNode: TCodeTreeNode); 120 function ExtractPropName(PropNode: TCodeTreeNode; 121 InUpperCase: boolean): string; 122 function ExtractProperty(PropNode: TCodeTreeNode; 123 Attr: TProcHeadAttributes): string; 124 function GetPropertyNameIdentifier(PropNode: TCodeTreeNode): PChar; 125 function GetPropertyTypeIdentifier(PropNode: TCodeTreeNode): PChar; 126 function PositionInPropertyName(PropNode: TCodeTreeNode; 127 CleanPos: integer): boolean; 128 function PropertyIsDefault(PropertyNode: TCodeTreeNode): boolean; 129 function PropertyNodeHasParamList(PropNode: TCodeTreeNode): boolean; 130 function PropNodeIsTypeLess(PropNode: TCodeTreeNode): boolean; 131 function PropertyHasSpecifier(PropNode: TCodeTreeNode; 132 UpperKeyword: string; ExceptionOnNotFound: boolean = true): boolean; 133 134 // procs 135 function ExtractProcName(ProcNode: TCodeTreeNode; 136 Attr: TProcHeadAttributes): string; 137 function ExtractProcHead(ProcNode: TCodeTreeNode; 138 Attr: TProcHeadAttributes): string; 139 function ExtractProcHeadWithGroup(ProcNode: TCodeTreeNode; 140 Attr: TProcHeadAttributes): TPascalMethodHeader; 141 function ExtractProcedureHeader(CursorPos: TCodeXYPosition; 142 Attributes: TProcHeadAttributes; var ProcHead: string): boolean; 143 function ExtractClassNameOfProcNode(ProcNode: TCodeTreeNode; 144 AddParentClasses: boolean = true): string; 145 function ProcNodeHasSpecifier(ProcNode: TCodeTreeNode; 146 ProcSpec: TProcedureSpecifier): boolean; 147 function GetProcNameIdentifier(ProcNode: TCodeTreeNode): PChar; 148 function FindProcNode(StartNode: TCodeTreeNode; const AProcHead: string; 149 AProcSpecType: TPascalMethodGroup; 150 Attr: TProcHeadAttributes; Visibility: TClassSectionVisibility = csvEverything): TCodeTreeNode; overload; 151 function FindProcNode(StartNode: TCodeTreeNode; const AProcHead: TPascalMethodHeader; 152 Attr: TProcHeadAttributes; Visibility: TClassSectionVisibility = csvEverything): TCodeTreeNode; overload; 153 function FindCorrespondingProcNode(ProcNode: TCodeTreeNode; 154 Attr: TProcHeadAttributes = [phpWithoutClassKeyword,phpWithoutClassName] 155 ): TCodeTreeNode; 156 function FindCorrespondingProcParamNode(ProcParamNode: TCodeTreeNode; 157 Attr: TProcHeadAttributes = [phpInUpperCase,phpWithoutClassName,phpWithVarModifiers] 158 ): TCodeTreeNode; 159 function FindProcBody(ProcNode: TCodeTreeNode): TCodeTreeNode; 160 function ProcBodyIsEmpty(ProcNode: TCodeTreeNode): boolean; 161 function ExtractProcedureGroup(ProcNode: TCodeTreeNode): TPascalMethodGroup; 162 function ExtractFuncResultType(ProcNode: TCodeTreeNode; 163 Attr: TProcHeadAttributes): string; 164 procedure MoveCursorToFirstProcSpecifier(ProcNode: TCodeTreeNode); 165 function MoveCursorToProcSpecifier(ProcNode: TCodeTreeNode; 166 ProcSpec: TProcedureSpecifier): boolean; 167 procedure MoveCursorToProcName(ProcNode: TCodeTreeNode; 168 SkipClassName: boolean); 169 procedure MoveCursorBehindProcName(ProcNode: TCodeTreeNode); 170 function PositionInProcName(ProcNode: TCodeTreeNode; 171 SkipClassName: boolean; CleanPos: integer): boolean; 172 function PositionInFuncResultName(ProcNode: TCodeTreeNode; 173 CleanPos: integer): boolean; 174 function ProcNodeHasParamList(ProcNode: TCodeTreeNode): boolean; 175 function ProcNodeHasOfObject(ProcNode: TCodeTreeNode): boolean; 176 function GetProcParamList(ProcNode: TCodeTreeNode; 177 Parse: boolean = true): TCodeTreeNode; 178 function NodeIsInAMethod(Node: TCodeTreeNode): boolean; 179 function NodeIsMethodBody(ProcNode: TCodeTreeNode): boolean; 180 function GetMethodOfBody(Node: TCodeTreeNode): TCodeTreeNode; 181 function NodeIsFunction(ProcNode: TCodeTreeNode): boolean; 182 function NodeIsClassConstructorOrDestructor(ProcNode: TCodeTreeNode): boolean; 183 function NodeIsConstructor(ProcNode: TCodeTreeNode): boolean; 184 function NodeIsDestructor(ProcNode: TCodeTreeNode): boolean; 185 function NodeIsForwardProc(ProcNode: TCodeTreeNode): boolean; 186 function NodeIsOperator(ProcNode: TCodeTreeNode): boolean; 187 function NodeIsResultIdentifier(Node: TCodeTreeNode): boolean; 188 function NodeIsResultType(Node: TCodeTreeNode): boolean; 189 190 // classes 191 function ExtractClassName(Node: TCodeTreeNode; 192 InUpperCase: boolean; WithParents: boolean = true; 193 WithGenericParams: boolean = false): string; 194 function ExtractClassPath(Node: TCodeTreeNode): string; 195 function ExtractClassInheritance(ClassNode: TCodeTreeNode; 196 Attr: TProcHeadAttributes): string; 197 function FindClassNode(StartNode: TCodeTreeNode; 198 const AClassName: string; // nested: A.B 199 IgnoreForwards, IgnoreNonForwards: boolean): TCodeTreeNode; 200 function FindClassNodeBackwards(StartNode: TCodeTreeNode; 201 const AClassName: string; 202 IgnoreForwards, IgnoreNonForwards: boolean): TCodeTreeNode; 203 function FindNestedClass(RootClassNode: TCodeTreeNode; 204 AClassName: PChar; SkipFirst: boolean): TCodeTreeNode; 205 function FindClassNode(CursorNode: TCodeTreeNode): TCodeTreeNode; 206 function FindClassNodeForMethodBody(ProcNode: TCodeTreeNode; 207 IgnoreForwards, IgnoreNonForwards: boolean): TCodeTreeNode; 208 function FindClassOrInterfaceNode(CursorNode: TCodeTreeNode; 209 FindClassOfMethod: boolean = false): TCodeTreeNode; 210 function FindClassSection(ClassNode: TCodeTreeNode; 211 NodeDesc: TCodeTreeNodeDesc): TCodeTreeNode; 212 function FindLastClassSection(ClassNode: TCodeTreeNode; 213 NodeDesc: TCodeTreeNodeDesc): TCodeTreeNode; 214 function GetClassVisibility(Node: TCodeTreeNode): TCodeTreeNodeDesc; 215 function FindClassNodeInInterface(const AClassName: string; 216 IgnoreForwards, IgnoreNonForwards, ErrorOnNotFound: boolean): TCodeTreeNode; 217 function FindClassNodeInUnit(const AClassName: string; 218 IgnoreForwards, IgnoreNonForwards, IgnoreImplementation, 219 ErrorOnNotFound: boolean): TCodeTreeNode; 220 function FindFirstIdentNodeInClass(ClassNode: TCodeTreeNode): TCodeTreeNode; 221 function FindLastIdentNodeInClass(ClassNode: TCodeTreeNode): TCodeTreeNode; 222 function FindNextIdentNodeInClass(Node: TCodeTreeNode): TCodeTreeNode; 223 function FindPriorIdentNodeInClass(Node: TCodeTreeNode): TCodeTreeNode; 224 function ClassSectionNodeStartsWithWord(ANode: TCodeTreeNode): boolean; 225 function IsClassNode(Node: TCodeTreeNode): boolean; // class, not object 226 function FindInheritanceNode(ClassNode: TCodeTreeNode): TCodeTreeNode; 227 function FindHelperForNode(HelperNode: TCodeTreeNode): TCodeTreeNode; 228 function IdentNodeIsInVisibleClassSection(Node: TCodeTreeNode; Visibility: TClassSectionVisibility): Boolean; 229 230 // records 231 function ExtractRecordCaseType(RecordCaseNode: TCodeTreeNode): string; 232 233 // variables, types 234 function FindVarNode(StartNode: TCodeTreeNode; 235 const UpperVarName: string; 236 Visibility: TClassSectionVisibility = csvEverything): TCodeTreeNode; 237 function FindTypeNodeOfDefinition( 238 DefinitionNode: TCodeTreeNode): TCodeTreeNode; 239 function NodeIsPartOfTypeDefinition(ANode: TCodeTreeNode): boolean; 240 function ExtractDefinitionNodeType(DefinitionNode: TCodeTreeNode): string; 241 function ExtractDefinitionName(DefinitionNode: TCodeTreeNode): string; 242 function FindDefinitionNameNode(DefinitionNode: TCodeTreeNode): TCodeTreeNode; 243 function PositionInDefinitionName(DefinitionNode: TCodeTreeNode; 244 CleanPos: integer): boolean; 245 function MoveCursorToParameterSpecifier(DefinitionNode: TCodeTreeNode 246 ): boolean; 247 function GetFirstGroupVarNode(VarNode: TCodeTreeNode): TCodeTreeNode; 248 function NodeIsIdentifierInInterface(Node: TCodeTreeNode): boolean; 249 function NodeCanHaveForwardType(TypeNode: TCodeTreeNode): boolean; 250 function NodeIsForwardType(TypeNode: TCodeTreeNode): boolean; 251 function FindForwardTypeNode(TypeNode: TCodeTreeNode; 252 SearchFirst: boolean): TCodeTreeNode; 253 function FindTypeOfForwardNode(TypeNode: TCodeTreeNode): TCodeTreeNode; 254 function FindEndOfWithExpr(WithVarNode: TCodeTreeNode): integer; 255 function ExtractWithBlockExpression(WithVarNode: TCodeTreeNode; Attr: TProcHeadAttributes = []): string; 256 function FindWithBlockStatement(WithVarNode: TCodeTreeNode): TCodeTreeNode; 257 258 // arrays 259 function ExtractArrayRange(ArrayNode: TCodeTreeNode; 260 Attr: TProcHeadAttributes): string; 261 262 // module sections 263 function ExtractSourceName: string; 264 function GetSourceNamePos(out NamePos: TAtomPosition): boolean; 265 function GetSourceName(DoBuildTree: boolean = true): string; 266 function GetSourceType: TCodeTreeNodeDesc; 267 function PositionInSourceName(CleanPos: integer): boolean; 268 269 // uses sections 270 procedure MoveCursorToUsesStart(UsesNode: TCodeTreeNode); 271 procedure MoveCursorToUsesEnd(UsesNode: TCodeTreeNode); 272 function ReadNextUsedUnit(out UnitNameRange, InAtom: TAtomPosition; 273 SyntaxExceptions: boolean = true): boolean; 274 procedure ReadPriorUsedUnit(out UnitNameRange, InAtom: TAtomPosition); 275 function ExtractUsedUnitNameAtCursor(InFilename: PAnsiString = nil): string; 276 function ExtractUsedUnitName(UseUnitNode: TCodeTreeNode; 277 InFilename: PAnsiString = nil): string; 278 function ReadAndCompareUsedUnit(const AnUnitName: string): boolean; 279 280 // comments 281 function FindCommentInFront(const StartPos: TCodeXYPosition; 282 const CommentText: string; InvokeBuildTree, SearchInParentNode, 283 WithCommentBounds, CaseSensitive, IgnoreSpaces, 284 CompareOnlyStart: boolean; 285 out CommentStart, CommentEnd: TCodeXYPosition): boolean; 286 function FindCommentInFront(StartPos: integer; 287 const CommentText: string; SearchInParentNode, 288 WithCommentBounds, CaseSensitive, IgnoreSpaces, 289 CompareOnlyStart: boolean; 290 out CommentStart, CommentEnd: integer): boolean; 291 function GetPasDocComments(const StartPos: TCodeXYPosition; 292 InvokeBuildTree: boolean; 293 out ListOfPCodeXYPosition: TFPList): boolean; 294 function GetPasDocComments(Node: TCodeTreeNode; 295 out ListOfPCodeXYPosition: TFPList): boolean; 296 297 procedure CalcMemSize(Stats: TCTMemStats); override; 298 end; 299 300function CompareMethodHeaders( 301 const Method1Name: string; Method1Group: TPascalMethodGroup; const Method1ResultType: string; 302 const Method2Name: string; Method2Group: TPascalMethodGroup; const Method2ResultType: string): Integer; overload; 303function CompareMethodHeaders(const Method1Head: TPascalMethodHeader; const Method2Head: TPascalMethodHeader): Integer; overload; 304function SameMethodHeaders( 305 const Method1Name: string; Method1Group: TPascalMethodGroup; const Method1ResultType: string; 306 const Method2Name: string; Method2Group: TPascalMethodGroup; const Method2ResultType: string): Boolean; overload; 307function SameMethodHeaders(const Method1Head: TPascalMethodHeader; const Method2Head: TPascalMethodHeader): Boolean; overload; 308function CompareCodeTreeNodeExtMethodHeaders(NodeData1, NodeData2: pointer): integer; 309 310implementation 311 312function CompareMethodHeaders(const Method1Name: string; 313 Method1Group: TPascalMethodGroup; const Method1ResultType: string; 314 const Method2Name: string; Method2Group: TPascalMethodGroup; 315 const Method2ResultType: string): Integer; 316begin 317 Result := (Ord(Method1Group) - Ord(Method2Group)); 318 if Result <> 0 then exit; 319 Result := CompareTextIgnoringSpace(Method1Name,Method2Name,false); 320 if Result <> 0 then exit; 321 if Method1Group=mgClassOperator then 322 Result := CompareTextIgnoringSpace(Method1ResultType,Method2ResultType,false); 323end; 324 325function CompareMethodHeaders(const Method1Head: TPascalMethodHeader; 326 const Method2Head: TPascalMethodHeader): Integer; 327begin 328 Result := CompareMethodHeaders( 329 Method1Head.Name, Method1Head.Group, Method1Head.ResultType, 330 Method2Head.Name, Method2Head.Group, Method2Head.ResultType); 331end; 332 333function SameMethodHeaders(const Method1Name: string; 334 Method1Group: TPascalMethodGroup; const Method1ResultType: string; 335 const Method2Name: string; Method2Group: TPascalMethodGroup; 336 const Method2ResultType: string): Boolean; 337begin 338 Result := CompareMethodHeaders( 339 Method1Name, Method1Group, Method1ResultType, 340 Method2Name, Method2Group, Method2ResultType) = 0; 341end; 342 343function SameMethodHeaders(const Method1Head: TPascalMethodHeader; 344 const Method2Head: TPascalMethodHeader): Boolean; 345begin 346 Result := CompareMethodHeaders(Method1Head, Method2Head) = 0; 347end; 348 349function CompareCodeTreeNodeExtMethodHeaders(NodeData1, NodeData2: pointer): integer; 350var 351 NodeExt1: TCodeTreeNodeExtension absolute NodeData1; 352 NodeExt2: TCodeTreeNodeExtension absolute NodeData2; 353begin 354 Result := CompareMethodHeaders( 355 NodeExt1.Txt,TPascalMethodGroup(NodeExt1.Flags),NodeExt1.ExtTxt4, 356 NodeExt2.Txt,TPascalMethodGroup(NodeExt2.Flags),NodeExt2.ExtTxt4); 357end; 358 359 360{ TPascalReaderTool } 361 362procedure TPascalReaderTool.RaiseStrConstExpected; 363begin 364 RaiseExceptionFmt(ctsStrExpectedButAtomFound,[ctsStringConstant,GetAtom]); 365end; 366 367function TPascalReaderTool.CleanPosIsInComment(CleanPos, 368 CleanCodePosInFront: integer; out CommentStart, CommentEnd: integer; 369 OuterCommentBounds: boolean): boolean; 370var CommentLvl, CurCommentPos: integer; 371 CurEnd: Integer; 372 CurCommentInnerEnd: Integer; 373begin 374 Result:=false; 375 CommentStart:=0; 376 CommentEnd:=0; 377 if CleanPos>SrcLen then exit; 378 if CleanCodePosInFront>CleanPos then 379 RaiseException( 380 'TPascalReaderTool.CleanPosIsInComment CleanCodePosInFront>CleanPos'); 381 MoveCursorToCleanPos(CleanCodePosInFront); 382 repeat 383 ReadNextAtom; 384 if CurPos.StartPos>CleanPos then begin 385 //DebugLn(['TPascalReaderTool.CleanPosIsInComment ',GetATom,' StartPos=',CurPos.StartPos,' CleanPos=',CleanPos]); 386 // CleanPos between two atoms -> parse space between for comments 387 if LastAtoms.Count>0 then 388 CommentStart:=LastAtoms.GetValueAt(0).EndPos 389 else 390 CommentStart:=CleanCodePosInFront; 391 CurEnd:=CurPos.StartPos; 392 if CurEnd>SrcLen then CurEnd:=SrcLen+1; 393 while CommentStart<CurEnd do begin 394 if IsCommentStartChar[Src[CommentStart]] then begin 395 CurCommentPos:=CommentStart; 396 CurCommentInnerEnd:=CurEnd; 397 case Src[CommentStart] of 398 '{': 399 begin 400 inc(CurCommentPos); 401 if (CurCommentPos<=SrcLen) and (Src[CurCommentPos]=#3) then begin 402 // codetools skip comment 403 inc(CurCommentPos); 404 if not OuterCommentBounds then CommentStart:=CurCommentPos; 405 while (CurCommentPos<CurEnd) do begin 406 if (Src[CurCommentPos]=#3) 407 and (CurCommentPos+1<CurEnd) and (Src[CurCommentPos+1]='}') 408 then begin 409 CurCommentInnerEnd:=CurCommentPos; 410 inc(CurCommentPos,2); 411 break; 412 end; 413 inc(CurCommentPos); 414 end; 415 end else begin 416 // pascal comment 417 if not OuterCommentBounds then CommentStart:=CurCommentPos; 418 CommentLvl:=1; 419 while (CurCommentPos<CurEnd) do begin 420 case Src[CurCommentPos] of 421 '{': if Scanner.NestedComments then inc(CommentLvl); 422 '}': 423 begin 424 dec(CommentLvl); 425 if (CommentLvl=0) then begin 426 CurCommentInnerEnd:=CurCommentPos; 427 inc(CurCommentPos); 428 break; 429 end; 430 end; 431 end; 432 inc(CurCommentPos); 433 end; 434 end; 435 end; 436 '/': // Delphi comment 437 if (CurCommentPos<SrcLen) and (Src[CurCommentPos+1]='/') then 438 begin 439 inc(CurCommentPos,2); 440 if not OuterCommentBounds then CommentStart:=CurCommentPos; 441 while (CurCommentPos<CurEnd) 442 and (not (Src[CurCommentPos] in [#10,#13])) do 443 inc(CurCommentPos); 444 CurCommentInnerEnd:=CurCommentPos; 445 inc(CurCommentPos); 446 if (CurCommentPos<CurEnd) 447 and (Src[CurCommentPos] in [#10,#13]) 448 and (Src[CurCommentPos-1]<>Src[CurCommentPos]) then 449 inc(CurCommentPos); 450 end else 451 break; 452 '(': // Turbo pascal comment 453 if (CurCommentPos<SrcLen) and (Src[CurCommentPos+1]='*') then 454 begin 455 inc(CurCommentPos,2); 456 if not OuterCommentBounds then CommentStart:=CurCommentPos; 457 while (CurCommentPos<CurEnd) do begin 458 if (Src[CurCommentPos]='*') and (CurCommentPos+1<CurEnd) 459 and (Src[CurCommentPos+1]=')') then 460 begin 461 CurCommentInnerEnd:=CurCommentPos; 462 inc(CurCommentPos,2); 463 break; 464 end; 465 inc(CurCommentPos); 466 end; 467 end else 468 break; 469 end; 470 if (CurCommentPos>CommentStart) and (CleanPos<CurCommentPos) then 471 begin 472 // CleanPos in comment 473 if OuterCommentBounds then 474 CommentEnd:=CurCommentPos 475 else 476 CommentEnd:=CurCommentInnerEnd; 477 exit(true); 478 end; 479 CommentStart:=CurCommentPos; 480 end else if IsSpaceChar[Src[CommentStart]] then begin 481 repeat 482 inc(CommentStart); 483 until (CommentStart>=CommentEnd) 484 or (not (IsSpaceChar[Src[CommentStart]])); 485 end else begin 486 break; 487 end; 488 end; 489 // CleanPos not in a comment 490 exit; 491 end else if CurPos.EndPos>CleanPos then begin 492 // CleanPos not in a comment 493 exit; 494 end; 495 CleanCodePosInFront:=CurPos.EndPos; 496 until CurPos.StartPos>=SrcLen; 497end; 498 499function TPascalReaderTool.ExtractPropType(PropNode: TCodeTreeNode; 500 InUpperCase, EmptyIfIndexed: boolean): string; 501begin 502 Result:=''; 503 if (PropNode=nil) 504 or ((PropNode.Desc<>ctnProperty) and (PropNode.Desc<>ctnGlobalProperty)) then 505 exit; 506 MoveCursorToNodeStart(PropNode); 507 ReadNextAtom; 508 if (PropNode.Desc=ctnProperty) then begin 509 if UpAtomIs('CLASS') then ReadNextAtom; 510 if (not UpAtomIs('PROPERTY')) then exit; 511 ReadNextAtom; 512 end; 513 AtomIsIdentifierE; 514 ReadNextAtom; 515 if CurPos.Flag=cafEdgedBracketOpen then begin 516 if EmptyIfIndexed then exit; 517 ReadTilBracketClose(true); 518 ReadNextAtom; 519 end; 520 if CurPos.Flag in [cafSemicolon,cafEND] then exit; 521 if not (CurPos.Flag=cafColon) then 522 RaiseExceptionFmt(ctsStrExpectedButAtomFound,[':',GetAtom]); 523 ReadNextAtom; 524 AtomIsIdentifierE; 525 if InUpperCase then 526 Result:=GetUpAtom 527 else 528 Result:=GetAtom; 529end; 530 531function TPascalReaderTool.ExtractProcName(ProcNode: TCodeTreeNode; 532 Attr: TProcHeadAttributes): string; 533var 534 ProcHeadNode: TCodeTreeNode; 535 Part: String; 536 HasClassName: Boolean; 537begin 538 Result:=''; 539 if [phpWithoutClassName,phpWithoutName]*Attr= 540 [phpWithoutClassName,phpWithoutName] 541 then 542 exit; 543 while (ProcNode<>nil) and (ProcNode.Desc<>ctnProcedure) do 544 ProcNode:=ProcNode.Parent; 545 if ProcNode=nil then exit; 546 ProcHeadNode:=ProcNode.FirstChild; 547 if (ProcHeadNode=nil) or (ProcHeadNode.StartPos<1) then exit; 548 MoveCursorToNodeStart(ProcHeadNode); 549 HasClassName:=false; 550 repeat 551 ReadNextAtom; 552 if not AtomIsIdentifier then break; 553 if phpInUpperCase in Attr then 554 Part:=GetUpAtom 555 else 556 Part:=GetAtom; 557 ReadNextAtom; 558 if (CurPos.Flag<>cafPoint) then begin 559 // end of method identifier is the proc name 560 if phpWithoutName in Attr then break; 561 if Result<>'' then Result:=Result+'.'; 562 Result:=Result+Part; 563 break; 564 end; 565 if not (phpWithoutClassName in Attr) then begin 566 // in front of . is class name 567 if Result<>'' then Result:=Result+'.'; 568 Result:=Result+Part; 569 HasClassName:=true; 570 end; 571 until false; 572 if (not HasClassName) 573 and ([phpWithoutClassName,phpAddClassName]*Attr=[phpAddClassName]) then begin 574 Part:=ExtractClassName(ProcNode,false,true); 575 if Part<>'' then 576 Result:=Part+'.'+Result; 577 end; 578end; 579 580function TPascalReaderTool.ExtractProcHead(ProcNode: TCodeTreeNode; 581 Attr: TProcHeadAttributes): string; 582var 583 TheClassName, s: string; 584 IsClassName, IsProcType: boolean; 585 IsProcedure: Boolean; 586 IsFunction: Boolean; 587 IsOperator: Boolean; 588 EndPos: Integer; 589 ParentNode: TCodeTreeNode; 590const 591 SemiColon : char = ';'; 592 593 procedure PrependName(const Prepend: string; var aPath: string); 594 begin 595 if Prepend='' then exit; 596 if aPath<>'' then 597 aPath:=Prepend+'.'+aPath 598 else 599 aPath:=Prepend; 600 end; 601 602begin 603 Result:=''; 604 ExtractProcHeadPos:=phepNone; 605 if (ProcNode=nil) or (ProcNode.StartPos<1) then exit; 606 if ProcNode.Desc=ctnProcedureHead then begin 607 ProcNode:=ProcNode.Parent; 608 if ProcNode=nil then exit; 609 end; 610 if ProcNode.Desc=ctnProcedure then 611 IsProcType:=false 612 else if ProcNode.Desc=ctnProcedureType then 613 IsProcType:=true 614 else 615 exit; 616 617 TheClassName:=''; 618 619 if (phpAddParentProcs in Attr) and (ProcNode.Parent.Desc=ctnProcedure) then begin 620 // local proc 621 ParentNode:=ProcNode.Parent; 622 while ParentNode.Desc=ctnProcedure do begin 623 PrependName(ExtractProcName(ParentNode,Attr*[phpInUpperCase]),TheClassName); 624 ParentNode:=ParentNode.Parent; 625 end; 626 end; 627 628 // build full class name 629 if ([phpAddClassname,phpWithoutClassName]*Attr=[phpAddClassName]) then 630 PrependName(ExtractClassName(ProcNode,phpInUpperCase in Attr,true),TheClassName); 631 632 // reparse the clean source 633 InitExtraction; 634 MoveCursorToNodeStart(ProcNode); 635 // parse procedure head = start + name + parameterlist + result type ; 636 ExtractNextAtom(false,Attr); 637 // read procedure start keyword 638 if (UpAtomIs('CLASS') or UpAtomIs('STATIC')) then 639 ExtractNextAtom((phpWithStart in Attr) 640 and not (phpWithoutClassKeyword in Attr),Attr); 641 IsProcedure:=UpAtomIs('PROCEDURE'); 642 IsFunction:=(not IsProcedure) and UpAtomIs('FUNCTION'); 643 IsOperator:=(not IsProcedure) and (not IsFunction) and UpAtomIs('OPERATOR'); 644 if IsProcedure or IsFunction or IsOperator 645 or (UpAtomIs('CONSTRUCTOR')) or (UpAtomIs('DESTRUCTOR')) 646 then 647 ExtractNextAtom(phpWithStart in Attr,Attr) 648 else 649 exit; 650 ExtractProcHeadPos:=phepStart; 651 if not IsProcType then begin 652 // read name 653 if ((not IsOperator) 654 or (not WordIsCustomOperator.DoItCaseInsensitive(Src,CurPos.StartPos,CurPos.EndPos-CurPos.StartPos))) 655 and (not AtomIsIdentifier) then exit; 656 657 if TheClassName<>'' then begin 658 s:=TheClassName+'.'; 659 if phpInUpperCase in Attr then s:=UpperCaseStr(s); 660 if ExtractStreamEndIsIdentChar then 661 s:=' '+s; 662 ExtractMemStream.Write(s[1],length(s)); 663 end; 664 665 if [phpWithoutClassName,phpWithoutName]*Attr=[] then begin 666 // read classname and name 667 repeat 668 ExtractNextAtom(true,Attr); 669 if Scanner.CompilerMode = cmDELPHI then 670 begin 671 // delphi generics 672 if AtomIsChar('<') then 673 begin 674 while not AtomIsChar('>') and (CurPos.EndPos < SrcLen) do 675 ExtractNextAtom(not (phpWithoutGenericParams in Attr),Attr); 676 ExtractNextAtom(not (phpWithoutGenericParams in Attr),Attr); 677 end; 678 end; 679 if CurPos.Flag<>cafPoint then break; 680 ExtractNextAtom(true,Attr); 681 if ((not IsOperator) 682 or (not WordIsCustomOperator.DoItCaseInsensitive(Src,CurPos.StartPos,CurPos.EndPos-CurPos.StartPos))) 683 and (not AtomIsIdentifier) then exit; 684 until false; 685 end else begin 686 // read only part of name 687 repeat 688 ReadNextAtom; 689 if (Scanner.CompilerMode = cmDELPHI) and AtomIsChar('<') then 690 begin 691 while not AtomIsChar('>') and (CurPos.EndPos < SrcLen) do 692 ReadNextAtom; 693 ReadNextAtom; 694 end; 695 IsClassName:=(CurPos.Flag=cafPoint); 696 UndoReadNextAtom; 697 if IsClassName then begin 698 // read class name 699 ExtractNextAtom(not (phpWithoutClassName in Attr),Attr); 700 // read '.' 701 ExtractNextAtom(not (phpWithoutClassName in Attr),Attr); 702 if ((not IsOperator) 703 or (not WordIsCustomOperator.DoItCaseInsensitive(Src,CurPos.StartPos,CurPos.EndPos-CurPos.StartPos))) 704 and (not AtomIsIdentifier) then exit; 705 end else begin 706 // read name 707 ExtractNextAtom(not (phpWithoutName in Attr),Attr); 708 break; 709 end; 710 until false; 711 end; 712 ExtractProcHeadPos:=phepName; 713 end; 714 // read parameter list 715 if (CurPos.Flag=cafRoundBracketOpen) then 716 ReadParamList(false,true,Attr); 717 ExtractProcHeadPos:=phepParamList; 718 if IsOperator and (CurPos.Flag=cafWord) then begin 719 // read operator result name 720 ExtractNextAtom([phpWithParameterNames,phpWithResultType]*Attr 721 =[phpWithParameterNames,phpWithResultType],Attr); 722 end; 723 // read result type 724 if (CurPos.Flag=cafColon) then begin 725 ExtractNextAtom(phpWithResultType in Attr,Attr); 726 if not AtomIsIdentifier then exit; 727 ExtractNextAtom(phpWithResultType in Attr,Attr); 728 if CurPos.Flag=cafPoint then begin 729 ExtractNextAtom(phpWithResultType in Attr,Attr); 730 if not AtomIsIdentifier then exit; 731 ExtractNextAtom(phpWithResultType in Attr,Attr); 732 end; 733 ExtractProcHeadPos:=phepResultType; 734 end; 735 // read 'of object' 736 if UpAtomIs('OF') then begin 737 if IsProcType then begin 738 ExtractNextAtom(phpWithOfObject in Attr,Attr); 739 if not UpAtomIs('OBJECT') then exit; 740 ExtractNextAtom(phpWithOfObject in Attr,Attr); 741 end; 742 end; 743 // read semicolon 744 if CurPos.Flag=cafSemicolon then 745 ExtractNextAtom(not (phpWithoutSemicolon in Attr),Attr); 746 // read specifiers 747 if [phpWithCallingSpecs,phpWithProcModifiers]*Attr<>[] then begin 748 if ProcNode.FirstChild<>nil then 749 EndPos:=ProcNode.FirstChild.EndPos 750 else 751 EndPos:=SrcLen+1; 752 while (CurPos.StartPos<EndPos) do begin 753 if CurPos.Flag=cafSemicolon then begin 754 ExtractNextAtom(phpWithProcModifiers in Attr,Attr); 755 end else begin 756 if IsKeyWordCallingConvention.DoIdentifier(@Src[CurPos.StartPos]) 757 then begin 758 ExtractNextAtom([phpWithCallingSpecs,phpWithProcModifiers]*Attr<>[], 759 Attr); 760 if not (phpWithProcModifiers in Attr) then 761 ExtractMemStream.Write(SemiColon,1); 762 end 763 else if (CurPos.Flag=cafEdgedBracketOpen) then begin 764 ReadTilBracketClose(false); 765 ExtractNextAtom(phpWithProcModifiers in Attr,Attr); 766 end else begin 767 ExtractNextAtom(phpWithProcModifiers in Attr,Attr); 768 end; 769 end; 770 end; 771 end; 772 773 // copy memorystream to Result string 774 Result:=GetExtraction(phpInUpperCase in Attr); 775 776 // add semicolon 777 if ([phpWithoutSemicolon,phpDoNotAddSemicolon]*Attr=[]) 778 and (Result<>'') and (Result[length(Result)]<>';') then 779 Result:=Result+';'; 780end; 781 782function TPascalReaderTool.ExtractProcHeadWithGroup(ProcNode: TCodeTreeNode; 783 Attr: TProcHeadAttributes): TPascalMethodHeader; 784begin 785 Result.Name := ExtractProcHead(ProcNode, Attr); 786 Result.Group := ExtractProcedureGroup(ProcNode); 787 if Result.Group=mgClassOperator then 788 Result.ResultType := ExtractFuncResultType(ProcNode, Attr); 789end; 790 791function TPascalReaderTool.ExtractProcedureHeader(CursorPos: TCodeXYPosition; 792 Attributes: TProcHeadAttributes; var ProcHead: string): boolean; 793var 794 CleanCursorPos: integer; 795 ANode: TCodeTreeNode; 796begin 797 Result:=false; 798 ProcHead:=''; 799 BuildTreeAndGetCleanPos(trTillCursor,lsrEnd,CursorPos,CleanCursorPos, 800 [btSetIgnoreErrorPos,btCursorPosOutAllowed]); 801 ANode:=FindDeepestNodeAtPos(CleanCursorPos,True); 802 while (ANode<>nil) and (ANode.Desc<>ctnProcedure) do 803 ANode:=ANode.Parent; 804 if ANode=nil then exit; 805 ProcHead:=ExtractProcHead(ANode,Attributes); 806 Result:=true; 807end; 808 809function TPascalReaderTool.ExtractClassName(Node: TCodeTreeNode; 810 InUpperCase: boolean; WithParents: boolean; WithGenericParams: boolean 811 ): string; 812var 813 ParamsNode: TCodeTreeNode; 814 ParamNode: TCodeTreeNode; 815 First: Boolean; 816begin 817 Result:=''; 818 while Node<>nil do begin 819 case Node.Desc of 820 ctnTypeDefinition: 821 begin 822 if Result<>'' then Result:='.'+Result; 823 Result:=GetIdentifier(@Src[Node.StartPos])+Result; 824 if not WithParents then break; 825 end; 826 ctnGenericType: 827 begin 828 if Result<>'' then Result:='.'+Result; 829 if (Node.Desc = ctnGenericType) then begin 830 // extract generic type param names 831 if WithGenericParams then begin 832 ParamsNode:=Node.FirstChild.NextBrother; 833 First:=true; 834 while ParamsNode<>nil do begin 835 if ParamsNode.Desc=ctnGenericParams then begin 836 Result:='>'+Result; 837 ParamNode:=ParamsNode.FirstChild; 838 while ParamNode<>nil do begin 839 if ParamNode.Desc=ctnGenericParameter then begin 840 if First then 841 First:=false 842 else 843 Result:=','+Result; 844 Result:=GetIdentifier(@Src[ParamNode.StartPos])+Result; 845 end; 846 ParamNode:=ParamNode.NextBrother; 847 end; 848 Result:='<'+Result; 849 end; 850 ParamsNode:=ParamsNode.NextBrother; 851 end; 852 end; 853 Result:=GetIdentifier(@Src[Node.FirstChild.StartPos])+Result; 854 end; 855 if not WithParents then break; 856 end; 857 ctnParameterList: 858 break; 859 end; 860 Node:=Node.Parent; 861 end; 862 863 if InUpperCase then 864 Result:=UpperCaseStr(Result); 865end; 866 867function TPascalReaderTool.ExtractClassPath(Node: TCodeTreeNode): string; 868var 869 InArray: Boolean; 870begin 871 Result:=''; 872 InArray:=false; 873 while Node<>nil do begin 874 case Node.Desc of 875 ctnTypeDefinition,ctnGenericType: 876 begin 877 if Result<>'' then Result:='.'+Result; 878 if Node.Desc=ctnTypeDefinition then 879 Result:=GetIdentifier(@Src[Node.StartPos])+Result 880 else if Node.FirstChild<>nil then 881 begin 882 if (Scanner.CompilerMode = cmDELPHI) and (Node.Desc = ctnGenericType) then 883 Result := Result + ExtractNode(Node.FirstChild.NextBrother, []); 884 Result:=GetIdentifier(@Src[Node.FirstChild.StartPos])+Result; 885 end; 886 end; 887 ctnParameterList: 888 break; 889 ctnRangedArrayType, ctnOpenArrayType: 890 begin 891 InArray := True; 892 Result := '[]' + Result; 893 end; 894 ctnVarDefinition: 895 if InArray then begin 896 Result := GetIdentifier(@Src[Node.StartPos]) + Result; 897 InArray := False; 898 end; 899 end; 900 Node:=Node.Parent; 901 end; 902end; 903 904function TPascalReaderTool.ExtractClassInheritance( 905 ClassNode: TCodeTreeNode; Attr: TProcHeadAttributes): string; 906begin 907 Result:=''; 908 if (ClassNode=nil) or (not (ClassNode.Desc in AllClasses)) then exit; 909 MoveCursorToNodeStart(ClassNode); 910 ReadNextAtom; // class 911 if UpAtomIs('PACKED') then ReadNextAtom; 912 if not (UpAtomIs('CLASS') or UpAtomIs('OBJECT') or UpAtomIs('OBJCLASS') 913 or (UpAtomIs('INTERFACE'))) 914 then 915 exit; 916 ReadNextAtom; // '(' 917 if CurPos.Flag<>cafRoundBracketOpen then exit; 918 ReadNextAtom; 919 if not AtomIsIdentifier then exit; 920 MoveCursorToCleanPos(CurPos.StartPos); 921 ExtractProcHeadPos:=phepNone; 922 InitExtraction; 923 while (CurPos.StartPos<=SrcLen) do begin 924 ExtractNextAtom(true,Attr); // read ancestor/interface 925 if not AtomIsIdentifier then break; 926 ExtractNextAtom(true,Attr); // read ',' 927 if not AtomIsChar(',') then break; 928 end; 929 // copy memorystream to Result string 930 Result:=GetExtraction(phpInUpperCase in Attr); 931end; 932 933function TPascalReaderTool.ExtractClassNameOfProcNode(ProcNode: TCodeTreeNode; 934 AddParentClasses: boolean): string; 935var 936 Part: String; 937begin 938 Result:=''; 939 if (ProcNode<>nil) and (ProcNode.Desc=ctnProcedure) then 940 ProcNode:=ProcNode.FirstChild; 941 if (ProcNode=nil) or (ProcNode.Desc<>ctnProcedureHead) then exit; 942 MoveCursorToNodeStart(ProcNode); 943 repeat 944 ReadNextAtom; 945 if not AtomIsIdentifier then break; 946 Part:=GetAtom; 947 ReadNextAtom; 948 if (Scanner.CompilerMode = cmDELPHI) and AtomIsChar('<') then 949 begin { delphi generics } 950 Part := Part + GetAtom; 951 repeat 952 ReadNextAtom; 953 Part := Part + GetAtom; 954 until (CurPos.StartPos > SrcLen) or AtomIsChar('>'); 955 ReadNextAtom; 956 end; 957 if (CurPos.Flag<>cafPoint) then break; 958 if Result<>'' then Result:=Result+'.'; 959 Result:=Result+Part; 960 until false; 961 if not AddParentClasses then exit; 962 Part:=ExtractClassName(ProcNode,false,true); 963 if Part='' then exit; 964 Result:=Part+'.'+Result; 965end; 966 967function TPascalReaderTool.FindProcNode(StartNode: TCodeTreeNode; 968 const AProcHead: TPascalMethodHeader; Attr: TProcHeadAttributes; 969 Visibility: TClassSectionVisibility): TCodeTreeNode; 970// search in all next brothers for a Procedure Node with the Name ProcName 971// if there are no further brothers and the parent is a section node 972// ( e.g. 'interface', 'implementation', ...) or a class visibility node 973// (e.g. 'public', 'private', ...) then the search will continue in the next 974// section 975var 976 InClass: Boolean; 977 CurProcHead: TPascalMethodHeader; 978begin 979 Result:=StartNode; 980 InClass:=FindClassOrInterfaceNode(StartNode)<>nil; 981 while (Result<>nil) do begin 982 if Result.Desc=ctnProcedure then begin 983 if (not ((phpIgnoreForwards in Attr) 984 and ((Result.SubDesc and ctnsForwardDeclaration)>0))) 985 and (not ((phpIgnoreProcsWithBody in Attr) 986 and (FindProcBody(Result)<>nil))) 987 and (not InClass or IdentNodeIsInVisibleClassSection(Result, Visibility)) 988 then 989 begin 990 CurProcHead:=ExtractProcHeadWithGroup(Result,Attr); 991 //DebugLn(['TPascalReaderTool.FindProcNode B "',CurProcHead,'" =? "',AProcHead,'" Result=',CompareTextIgnoringSpace(CurProcHead,AProcHead,false)]); 992 if (CurProcHead.Name<>'') and 993 SameMethodHeaders(AProcHead, CurProcHead) 994 then 995 exit; 996 end; 997 end; 998 // next node 999 if InClass then 1000 Result:=FindNextIdentNodeInClass(Result) 1001 else 1002 Result:=FindNextNodeOnSameLvl(Result); 1003 end; 1004end; 1005 1006function TPascalReaderTool.FindProcNode(StartNode: TCodeTreeNode; 1007 const AProcHead: string; AProcSpecType: TPascalMethodGroup; 1008 Attr: TProcHeadAttributes; Visibility: TClassSectionVisibility): TCodeTreeNode; 1009var 1010 ProcHead: TPascalMethodHeader; 1011begin 1012 ProcHead.Name := AProcHead; 1013 ProcHead.Group := AProcSpecType; 1014 Result := FindProcNode(StartNode, ProcHead, Attr, Visibility); 1015end; 1016 1017function TPascalReaderTool.FindCorrespondingProcNode(ProcNode: TCodeTreeNode; 1018 Attr: TProcHeadAttributes): TCodeTreeNode; 1019var 1020 ClassNode: TCodeTreeNode; 1021 StartNode: TCodeTreeNode; 1022 ProcHead: TPascalMethodHeader; 1023begin 1024 Result:=nil; 1025 // get ctnProcedure 1026 //debugln('TPascalReaderTool.FindCorrespondingProcNode Start'); 1027 if (ProcNode=nil) then exit; 1028 if ProcNode.Desc=ctnProcedureHead then begin 1029 ProcNode:=ProcNode.Parent; 1030 if (ProcNode=nil) then exit; 1031 end; 1032 if ProcNode.Desc<>ctnProcedure then exit; 1033 1034 // check proc kind 1035 //debugln('TPascalReaderTool.FindCorrespondingProcNode Check kind'); 1036 ClassNode:=FindClassOrInterfaceNode(ProcNode); 1037 if ClassNode<>nil then begin 1038 //debugln('TPascalReaderTool.FindCorrespondingProcNode Class'); 1039 // in a class definition -> search method body 1040 StartNode:=ClassNode.GetTopMostNodeOfType(ctnTypeSection); 1041 end else if NodeIsMethodBody(ProcNode) then begin 1042 //debugln('TPascalReaderTool.FindCorrespondingProcNode Method ',ExtractClassNameOfProcNode(ProcNode)); 1043 // in a method body -> search in class 1044 StartNode:=FindClassNodeInUnit(ExtractClassNameOfProcNode(ProcNode,true), 1045 true,false,false,true); 1046 if StartNode=nil then exit; 1047 if (StartNode<>nil) and (StartNode.Desc in AllClasses) 1048 then begin 1049 StartNode:=StartNode.FirstChild; 1050 while (StartNode<>nil) do begin 1051 if (StartNode.Desc in AllClassBaseSections) 1052 and (StartNode.FirstChild<>nil) then begin 1053 StartNode:=StartNode.FirstChild; 1054 break; 1055 end; 1056 StartNode:=StartNode.NextBrother; 1057 end; 1058 end; 1059 end else begin 1060 //DebugLn('TPascalReaderTool.FindCorrespondingProcNode Normal'); 1061 // else: search on same lvl 1062 StartNode:=FindFirstNodeOnSameLvl(ProcNode); 1063 end; 1064 if StartNode=nil then exit; 1065 1066 ProcHead:=ExtractProcHeadWithGroup(ProcNode,Attr); 1067 //debugln('TPascalReaderTool.FindCorrespondingProcNode StartNode=',StartNode.DescAsString,' ProcHead=',dbgstr(ProcHead),' ',dbgs(Attr),' ',StartNode.DescAsString); 1068 Result:=FindProcNode(StartNode,ProcHead,Attr); 1069 if Result=ProcNode then begin 1070 // found itself -> search further 1071 StartNode:=FindNextNodeOnSameLvl(Result); 1072 Result:=FindProcNode(StartNode,ProcHead,Attr); 1073 end; 1074 //if Result<>nil then debugln(['TPascalReaderTool.FindCorrespondingProcNode Result=',CleanPosToStr(Result.StartPos),' ',dbgstr(copy(Src,Result.StartPos,50))]); 1075end; 1076 1077function TPascalReaderTool.FindCorrespondingProcParamNode( 1078 ProcParamNode: TCodeTreeNode; Attr: TProcHeadAttributes): TCodeTreeNode; 1079var 1080 ProcNode: TCodeTreeNode; 1081begin 1082 Result:=nil; 1083 if ProcParamNode=nil then exit; 1084 if (ProcParamNode.Desc=ctnVarDefinition) 1085 and (ProcParamNode.Parent.Desc=ctnParameterList) 1086 and (ProcParamNode.Parent.Parent.Desc=ctnProcedureHead) then begin 1087 // this is a parameter name 1088 ProcNode:=ProcParamNode.GetNodeOfType(ctnProcedure); 1089 if ProcNode=nil then exit; 1090 // search alias for parameter 1091 ProcNode:=FindCorrespondingProcNode(ProcNode,Attr); 1092 if ProcNode=nil then exit; 1093 BuildSubTreeForProcHead(ProcNode); 1094 Result:=ProcNode; 1095 while (Result<>nil) do begin 1096 //debugln(['TPascalReaderTool.FindCorrespondingProcParamNode ',dbgstr(copy(Src,Result.StartPos,20))]); 1097 if Result.Desc 1098 in [ctnProcedure,ctnProcedureHead,ctnParameterList] 1099 then 1100 Result:=Result.FirstChild 1101 else begin 1102 if Result.StartPos<1 then break; 1103 if CompareIdentifiers(@Src[ProcParamNode.StartPos],@Src[Result.StartPos])=0 1104 then exit; 1105 Result:=Result.NextBrother; 1106 end; 1107 end; 1108 Result:=nil; 1109 end; 1110end; 1111 1112function TPascalReaderTool.FindDefinitionNameNode(DefinitionNode: TCodeTreeNode 1113 ): TCodeTreeNode; 1114begin 1115 if DefinitionNode.Desc=ctnGenericType then 1116 begin 1117 if DefinitionNode.FirstChild<>nil then 1118 Result:=DefinitionNode.FirstChild 1119 else 1120 Result:=nil; 1121 end else 1122 Result:=DefinitionNode; 1123end; 1124 1125function TPascalReaderTool.FindProcBody(ProcNode: TCodeTreeNode): TCodeTreeNode; 1126begin 1127 Result:=ProcNode; 1128 if Result=nil then exit; 1129 if Result.Desc<>ctnProcedure then exit; 1130 Result:=Result.LastChild; 1131 while Result<>nil do begin 1132 if Result.Desc in [ctnBeginBlock,ctnAsmBlock] then 1133 exit; 1134 Result:=Result.PriorBrother; 1135 end; 1136end; 1137 1138function TPascalReaderTool.ProcBodyIsEmpty(ProcNode: TCodeTreeNode): boolean; 1139var 1140 BodyNode: TCodeTreeNode; 1141 LastPos: LongInt; 1142begin 1143 Result:=false; 1144 BodyNode:=FindProcBody(ProcNode); 1145 if (BodyNode=nil) then exit; 1146 // check if there are nodes in front (e.g. local variables) 1147 if (BodyNode.PriorBrother<>nil) 1148 and (BodyNode.PriorBrother.Desc<>ctnProcedureHead) then 1149 exit; 1150 // check if there are child nodes 1151 if BodyNode.FirstChild<>nil then exit; 1152 // check if bodynode is only 'asm end' or 'begin end' 1153 // not even a comment should be there, only spaces are allowed 1154 if ProcNode.FirstChild.Desc<>ctnProcedureHead then exit; 1155 MoveCursorToCleanPos(ProcNode.FirstChild.EndPos); 1156 LastPos:=CurPos.EndPos; 1157 ReadNextAtom; 1158 if FindNextNonSpace(Src,LastPos)<>CurPos.StartPos then exit; 1159 if CurPos.Flag=cafSemicolon then begin 1160 // semicolon is allowed 1161 LastPos:=CurPos.EndPos; 1162 ReadNextAtom; 1163 if FindNextNonSpace(Src,LastPos)<>CurPos.StartPos then exit; 1164 end; 1165 if not (UpAtomIs('ASM') or UpAtomIs('BEGIN')) then exit; 1166 LastPos:=CurPos.EndPos; 1167 ReadNextAtom; 1168 if FindNextNonSpace(Src,LastPos)<>CurPos.StartPos then exit; 1169 // inherited is allowed 1170 if UpAtomIs('INHERITED') then begin 1171 ReadNextAtom; 1172 if CurPos.Flag=cafSemicolon then begin 1173 // semicolon is allowed 1174 LastPos:=CurPos.EndPos; 1175 ReadNextAtom; 1176 if FindNextNonSpace(Src,LastPos)<>CurPos.StartPos then exit; 1177 end; 1178 end; 1179 if not UpAtomIs('END') then exit; 1180 Result:=true; 1181end; 1182 1183procedure TPascalReaderTool.MoveCursorToFirstProcSpecifier(ProcNode: TCodeTreeNode); 1184// After the call, 1185// CurPos will stand on the first proc specifier or on a semicolon 1186// this can be 'of object' 1187begin 1188 //DebugLn(['TPascalReaderTool.MoveCursorToFirstProcSpecifier ',ProcNode.DescAsString,' ',ProcNode.StartPos]); 1189 if (ProcNode<>nil) and (ProcNode.Desc in [ctnProcedureType,ctnProcedure]) then 1190 ProcNode:=ProcNode.FirstChild; 1191 if (ProcNode=nil) or (ProcNode.Desc<>ctnProcedureHead) then begin 1192 RaiseException('Internal Error in' 1193 +' TPascalParserTool.MoveCursorFirstProcSpecifier: ' 1194 +' (ProcNode=nil) or (ProcNode.Desc<>ctnProcedure)'); 1195 end; 1196 if (ProcNode.LastChild<>nil) and (ProcNode.LastChild.Desc=ctnIdentifier) then 1197 begin 1198 // jump behind function result type 1199 MoveCursorToCleanPos(ProcNode.LastChild.EndPos); 1200 ReadNextAtom; 1201 end else if (ProcNode.FirstChild<>nil) 1202 and (ProcNode.FirstChild.Desc=ctnParameterList) 1203 then begin 1204 // jump behind parameter list 1205 MoveCursorToCleanPos(ProcNode.FirstChild.EndPos); 1206 ReadNextAtom; 1207 end else begin 1208 MoveCursorToNodeStart(ProcNode); 1209 ReadNextAtom; 1210 if AtomIsCustomOperator(true,false,false) then begin 1211 // read name 1212 ReadNextAtom; 1213 while (CurPos.Flag=cafPoint) do begin 1214 ReadNextAtom; 1215 if CurPos.Flag in [cafPoint,cafRoundBracketOpen,cafEdgedBracketOpen,cafColon,cafEnd,cafSemicolon] 1216 then break; 1217 ReadNextAtom; 1218 end; 1219 end; 1220 if (CurPos.Flag=cafRoundBracketOpen) then begin 1221 // read paramlist 1222 ReadTilBracketClose(false); 1223 ReadNextAtom; 1224 end; 1225 end; 1226 if (CurPos.Flag=cafColon) then begin 1227 // read function result type 1228 ReadNextAtom; 1229 if AtomIsIdentifier then begin 1230 ReadNextAtom; 1231 while CurPos.Flag=cafPoint do begin 1232 ReadNextAtom; 1233 if not AtomIsIdentifier then break; 1234 ReadNextAtom; 1235 end; 1236 end; 1237 end; 1238 // CurPos now stands on the first proc specifier or on a semicolon or on the syntax error 1239end; 1240 1241function TPascalReaderTool.MoveCursorToProcSpecifier(ProcNode: TCodeTreeNode; 1242 ProcSpec: TProcedureSpecifier): boolean; 1243begin 1244 if ProcNode.FirstChild=nil then begin 1245 exit(false); 1246 end; 1247 MoveCursorToFirstProcSpecifier(ProcNode); 1248 while (CurPos.StartPos<=ProcNode.FirstChild.EndPos) do begin 1249 if CurPos.Flag=cafSemicolon then begin 1250 ReadNextAtom; 1251 end else begin 1252 if UpAtomIs(ProcedureSpecifierNames[ProcSpec]) then begin 1253 Result:=true; 1254 exit; 1255 end; 1256 if (CurPos.Flag=cafEdgedBracketOpen) then begin 1257 ReadTilBracketClose(false); 1258 ReadNextAtom; 1259 end else if UpAtomIs('MESSAGE') then begin 1260 ReadNextAtom; 1261 ReadConstant(true,false,[]); 1262 end else if UpAtomIs('EXTERNAL') then begin 1263 ReadNextAtom; 1264 if CurPos.Flag<>cafSemicolon then begin 1265 if not UpAtomIs('NAME') then 1266 ReadConstant(true,false,[]); 1267 if UpAtomIs('NAME') or UpAtomIs('INDEX') then begin 1268 ReadNextAtom; 1269 ReadConstant(true,false,[]); 1270 end; 1271 end; 1272 end else begin 1273 ReadNextAtom; 1274 end; 1275 end; 1276 end; 1277 Result:=false; 1278end; 1279 1280procedure TPascalReaderTool.MoveCursorToProcName(ProcNode: TCodeTreeNode; 1281 SkipClassName: boolean); 1282begin 1283 if (ProcNode.Desc=ctnProcedure) and (ProcNode.FirstChild<>nil) 1284 and (ProcNode.FirstChild.Desc=ctnProcedureHead) then 1285 ProcNode:=ProcNode.FirstChild; 1286 MoveCursorToNodeStart(ProcNode); 1287 ReadNextAtom; 1288 if (ProcNode.Desc=ctnProcedure) then begin 1289 if UpAtomIs('CLASS') then ReadNextAtom; 1290 ReadNextAtom; // skip proc keyword 1291 end; 1292 if not SkipClassName then exit; 1293 repeat 1294 ReadNextAtom; 1295 if CurPos.Flag<>cafPoint then begin 1296 UndoReadNextAtom; 1297 break; 1298 end; 1299 ReadNextAtom; 1300 until not AtomIsIdentifier; 1301end; 1302 1303procedure TPascalReaderTool.MoveCursorBehindProcName(ProcNode: TCodeTreeNode); 1304begin 1305 if (ProcNode.FirstChild<>nil) 1306 and (ProcNode.FirstChild.Desc=ctnProcedureHead) then 1307 ProcNode:=ProcNo…
Large files files are truncated, but you can click here to view the full file