PageRenderTime 50ms CodeModel.GetById 28ms app.highlight 9ms RepoModel.GetById 1ms app.codeStats 1ms

/components/codetools/pascalreadertool.pas

http://github.com/graemeg/lazarus
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