codetools: started GetExpandedOperand

git-svn-id: trunk@32262 -

.gitattributes

@@ -452,6 +452,8 @@ components/codetools/examples/fpcunitlinks.lpi svneol=native#text/plain
 components/codetools/examples/fpcunitlinks.pas svneol=native#text/pascal
 components/codetools/examples/getcontext.lpi svneol=native#text/plain
 components/codetools/examples/getcontext.lpr svneol=native#text/plain
+components/codetools/examples/getexpandedoperand.lpi svneol=native#text/plain
+components/codetools/examples/getexpandedoperand.pas svneol=native#text/plain
 components/codetools/examples/h2pastest.lpi svneol=native#text/plain
 components/codetools/examples/h2pastest.lpr svneol=native#text/plain
 components/codetools/examples/identifiercompletion.lpi svneol=native#text/plain
@@ -489,6 +491,7 @@ components/codetools/examples/scanexamples/empty.inc svneol=native#text/plain
 components/codetools/examples/scanexamples/emptymethods1.pas svneol=native#text/plain
 components/codetools/examples/scanexamples/genericsexample.pas svneol=native#text/plain
 components/codetools/examples/scanexamples/getcontextexample.pas svneol=native#text/plain
+components/codetools/examples/scanexamples/getterexample1.pas svneol=native#text/plain
 components/codetools/examples/scanexamples/identcomplexample.pas svneol=native#text/plain
 components/codetools/examples/scanexamples/indentation.pas svneol=native#text/plain
 components/codetools/examples/scanexamples/methodjump1.pas svneol=native#text/plain

components/codetools/codetoolmanager.pas

@@ -504,6 +504,8 @@ type
     function ExtractOperand(Code: TCodeBuffer; X,Y: integer;
           out Operand: string; WithPostTokens, WithAsOperator,
           WithoutTrailingPoints: boolean): boolean;
+    function GetExpandedOperand(Code: TCodeBuffer; X, Y: Integer;
+          out Operand: string; ResolveProperty: Boolean): Boolean;
 
     // code completion = auto class completion, auto forward proc completion,
     //             local var assignment completion, event assignment completion
@@ -2877,6 +2879,24 @@ begin
   end;
 end;
 
+function TCodeToolManager.GetExpandedOperand(Code: TCodeBuffer; X, Y: Integer;
+  out Operand: string; ResolveProperty: Boolean): Boolean;
+var
+  CursorPos: TCodeXYPosition;
+begin
+  Result := False;
+  Operand := '';
+  if not InitCurCodeTool(Code) then Exit;
+  CursorPos.X := X;
+  CursorPos.Y := Y;
+  CursorPos.Code := Code;
+  try
+    Result := FCurCodeTool.GetExpandedOperand(CursorPos, Operand, ResolveProperty);
+  except
+    on e: Exception do HandleException(e);
+  end;
+end;
+
 function TCodeToolManager.GuessMisplacedIfdefEndif(Code: TCodeBuffer; X,Y: integer;
   var NewCode: TCodeBuffer;
   var NewX, NewY, NewTopLine: integer): boolean;

components/codetools/examples/getexpandedoperand.lpi

@@ -0,0 +1,68 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <General>
+      <Flags>
+        <LRSInOutputDirectory Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="getexpandedoperand"/>
+      <UseAppBundle Value="False"/>
+    </General>
+    <BuildModes Count="1">
+      <Item1 Name="default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="CodeTools"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="4">
+      <Unit0>
+        <Filename Value="getexpandedoperand.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="getexpandedoperand"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="scanexamples/simpleunit1.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="SimpleUnit1"/>
+      </Unit1>
+      <Unit2>
+        <Filename Value="scanexamples/overloadedfunction.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="OverloadedFunction"/>
+      </Unit2>
+      <Unit3>
+        <Filename Value="scanexamples/getterexample1.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="getterexample1"/>
+      </Unit3>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="10"/>
+    <SearchPaths>
+      <OtherUnitFiles Value="scanexamples"/>
+    </SearchPaths>
+    <Other>
+      <CompilerMessages>
+        <UseMsgFile Value="True"/>
+      </CompilerMessages>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+</CONFIG>

components/codetools/examples/getexpandedoperand.pas

@@ -0,0 +1,90 @@
+{
+ ***************************************************************************
+ *                                                                         *
+ *   This source is free software; you can redistribute it and/or modify   *
+ *   it under the terms of the GNU General Public License as published by  *
+ *   the Free Software Foundation; either version 2 of the License, or     *
+ *   (at your option) any later version.                                   *
+ *                                                                         *
+ *   This code is distributed in the hope that it will be useful, but      *
+ *   WITHOUT ANY WARRANTY; without even the implied warranty of            *
+ *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *
+ *   General Public License for more details.                              *
+ *                                                                         *
+ *   A copy of the GNU General Public License is available on the World    *
+ *   Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also      *
+ *   obtain it by writing to the Free Software Foundation,                 *
+ *   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.        *
+ *                                                                         *
+ ***************************************************************************
+
+  Author: Mattias Gaertner
+  
+  Abstract:
+    Simple demonstrating, how to setup the codetools, FPC and Lazarus Source
+    directory to find a declaration.
+}
+program getexpandedoperand;
+
+{$mode objfpc}{$H+}
+
+uses
+  Classes, SysUtils, CodeCache, CodeToolManager, DefineTemplates, FileProcs,
+  CodeToolsConfig, SimpleUnit1, getterexample1;
+
+const
+  ConfigFilename = 'codetools.config';
+var
+  Code: TCodeBuffer;
+  X: Integer;
+  Y: Integer;
+  Filename: String;
+  Line: String;
+  Operand: string;
+begin
+  Filename:='scanexamples/getterexample1.pas';
+  X:=20;
+  Y:=53;
+  if (ParamCount>=1) and (Paramcount<3) then begin
+    writeln('Usage:');
+    writeln('  ',ParamStr(0));
+    writeln('  ',ParamStr(0),' <filename> <X> <Y>');
+    writeln('  ',ParamStr(0),' ',Filename,' ',X,' ',Y);
+  end;
+
+  CodeToolBoss.SimpleInit(ConfigFilename);
+
+  if (ParamCount=3) then begin
+    Filename:=ParamStr(1);
+    X:=StrToInt(ParamStr(2));
+    Y:=StrToInt(ParamStr(3));
+  end;
+  Filename:=TrimAndExpandFilename(Filename);
+  writeln('File: ',Filename,' Line=',Y,' Column=',X);
+
+  try
+    // Step 1: load the file
+    Code:=CodeToolBoss.LoadFile(Filename,false,false);
+    if Code=nil then
+      raise Exception.Create('loading failed '+Filename);
+
+    Line:=Code.GetLine(Y-1);
+    writeln('Line ',Y,': ',copy(Line,1,X-1),'|',copy(Line,X,length(Line)));
+
+    // Step 2: find declaration
+    if CodeToolBoss.GetExpandedOperand(Code,X,Y,Operand,false) then
+    begin
+      writeln('Operand: ',Operand);
+    end else begin
+      if CodeToolBoss.ErrorMessage<>'' then
+        writeln('Parse error: ',CodeToolBoss.ErrorMessage)
+      else
+        writeln('Declaration not found');
+    end;
+  except
+    on E: Exception do begin
+      writeln('Error: ',E.Message);
+    end;
+  end;
+end.
+

components/codetools/examples/scanexamples/getterexample1.pas

@@ -0,0 +1,58 @@
+unit getterexample1;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils;
+
+type
+
+  { TOldest }
+
+  TOldest = class
+  private
+    FBar: integer;
+    function GetBar: integer; virtual;
+  public
+    property Bar: integer read GetBar;
+  end;
+
+  { TOlder }
+
+  TOlder = class(TOldest)
+  private
+    function GetBar: integer; override;
+  public
+    procedure DoSomething;
+  end;
+
+implementation
+
+{ TOldest }
+
+function TOldest.GetBar: integer;
+begin
+  Result:=FBar;
+end;
+
+{ TOlder }
+
+function TOlder.GetBar: integer;
+begin
+  Result:=FBar;
+end;
+
+procedure TOlder.DoSomething;
+var
+  Older: TOlder;
+begin
+  Older:=TOlder.Create;
+  with Older do begin
+    writeln(Older.Bar);
+  end;
+end;
+
+end.
+

components/codetools/finddeclarationtool.pas

@@ -166,12 +166,15 @@ type
     fdfCollect,             // return every reachable identifier
     fdfTopLvlResolving,     // set, when searching for an identifier of the
                             //   top lvl variable. Calling DoOnIdentifierFound.
-    fdfDoNotCache           // result will not be cached
+    fdfDoNotCache,          // result will not be cached
+    fdfExtractOperand,      // operand will be extracted
+    fdfPropertyResolving    // used with fdfExtractOperand to resolve properties to getters
     );
   TFindDeclarationFlags = set of TFindDeclarationFlag;
   
 const
-  fdfGlobals = [fdfExceptionOnNotFound, fdfTopLvlResolving];
+  fdfGlobals = [fdfExceptionOnNotFound, fdfTopLvlResolving,
+                fdfExtractOperand, fdfPropertyResolving];
   fdfGlobalsSameIdent = fdfGlobals+[fdfExceptionOnPredefinedIdent,
                 fdfIgnoreMissingParams, fdfIgnoreUsedUnits, fdfDoNotCache,
                 fdfOnlyCompatibleProc, fdfSearchInAncestors, fdfCollect];
@@ -198,7 +201,9 @@ const
     'fdfSkipClassForward',
     'fdfCollect',
     'fdfTopLvlResolving',
-    'fdfDoNotCache'
+    'fdfDoNotCache',
+    'fdfExtractOperand',
+    'fdfPropertyResolving'
   );
 
 type
@@ -477,6 +482,7 @@ type
   private
     FirstFoundProc: PFoundProc;//list of all saved PFoundProc
     LastFoundProc: PFoundProc;
+    FExtractedOperand: string;
     procedure FreeFoundProc(aFoundProc: PFoundProc; FreeNext: boolean);
     procedure RemoveFoundProcFromList(aFoundProc: PFoundProc);
   public
@@ -515,6 +521,8 @@ type
     procedure SetGenericParamValues(SpecializeParamsTool: TFindDeclarationTool;
                 SpecializeNode: TCodeTreeNode);
     function FindGenericParamType: Boolean;
+    procedure AddOperandPart;
+    property ExtractedOperand: string read FExtractedOperand;
     procedure ChangeFoundProc(const ProcContext: TFindContext;
                               ProcCompatibility: TTypeCompatibility;
                               ParamCompatibilityList: TTypeCompatibilityList);
@@ -867,6 +875,9 @@ type
         IgnoreJumpCentered: boolean): boolean;
     function NodeIsForwardDeclaration(Node: TCodeTreeNode): boolean;
 
+    function GetExpandedOperand(const CursorPos: TCodeXYPosition;
+          out Operand: string; ResolveProperty: Boolean): Boolean;
+
     property InterfaceIdentifierCache: TInterfaceIdentifierCache
                                                  read FInterfaceIdentifierCache;
     property OnGetUnitSourceSearchPath: TOnGetSearchPath
@@ -2531,7 +2542,7 @@ var
   begin
     Result:=false;
     // the node cache is identifier based
-    if (fdfCollect in Params.Flags) then exit;
+    if ([fdfCollect,fdfExtractOperand]*Params.Flags<>[]) then exit;
     
     NodeCache:=GetNodeCache(ContextNode,false);
     if (NodeCache<>LastNodeCache) then begin
@@ -2581,7 +2592,7 @@ var
     if not Found then exit;
     FindIdentifierInContext:=true;
     if (FirstSearchedNode=nil) then exit;
-    if ([fdfDoNotCache,fdfCollect]*Params.Flags<>[]) then exit;
+    if ([fdfDoNotCache,fdfCollect,fdfExtractOperand]*Params.Flags<>[]) then exit;
     if ([fodDoNotCache]*Params.NewFlags<>[]) then exit;
     if (Params.OnIdentifierFound<>@CheckSrcIdentifier) then exit;
     if (Params.FoundProc<>nil) then exit; // do not cache proc searches
@@ -2634,6 +2645,27 @@ var
     {$ENDIF}
     if NewResult then begin
       // identifier found
+      if fdfExtractOperand in Params.Flags then
+        case Params.NewNode.Desc of
+          ctnVarDefinition, ctnConstDefinition:
+            Params.AddOperandPart;
+          ctnProperty:
+            begin
+              if fdfPropertyResolving in Params.Flags then begin
+                if not PropNodeIsTypeLess(Params.NewNode)
+                and ReadTilGetterOfProperty(Params.NewNode) then begin
+                  // continue searching of getter
+                  Params.Identifier := @Src[CurPos.StartPos];
+                end;
+                ContextNode := Params.NewNode;
+                Exit(False);
+              end else Params.AddOperandPart;
+            end;
+          ctnProcedure:
+            // function execution is not implemented yet
+            RaiseException('not implemented');
+        end;
+
       if CallOnIdentifierFound then begin
         {
         debugln('[TFindDeclarationTool.FindIdentifierInContext.CheckResult] CallOnIdentifierFound Ident=',
@@ -3253,7 +3285,7 @@ begin
   end;}
   // if we are here, the identifier was not found and there was no error
   if (FirstSearchedNode<>nil) and (Params.FoundProc=nil)
-  and (not (fdfCollect in Params.Flags)) then begin
+  and ([fdfCollect,fdfExtractOperand]*Params.Flags=[]) then begin
     // add result to cache
     Params.NewNode:=nil;
     Params.NewCodeTool:=nil;
@@ -4937,6 +4969,78 @@ begin
   end;
 end;
 
+function TFindDeclarationTool.GetExpandedOperand(const CursorPos: TCodeXYPosition;
+  out Operand: string; ResolveProperty: Boolean): Boolean;
+var
+  CursorNode: TCodeTreeNode;
+  CleanCursorPos: integer;
+  Params: TFindDeclarationParams;
+  Identifier: PChar;
+  LineRange: TLineRange;
+begin
+  Result := False;
+  Operand := '';
+  if (CursorPos.Y<1) or (CursorPos.Y>CursorPos.Code.LineCount)
+  or (CursorPos.X<1) then Exit;
+  CursorPos.Code.GetLineRange(CursorPos.Y-1,LineRange);
+  if LineRange.EndPos-LineRange.StartPos+1<CursorPos.X then Exit;
+
+  ActivateGlobalWriteLock;
+  try
+    // build code tree
+    if DirtySrc<>nil then DirtySrc.Clear;
+    BuildTreeAndGetCleanPos(trTillCursor,lsrEnd,CursorPos,CleanCursorPos,
+                  [btSetIgnoreErrorPos,btLoadDirtySource,btCursorPosOutAllowed]);
+    // find CodeTreeNode at cursor
+    if (Tree.Root<>nil) and (Tree.Root.StartPos<=CleanCursorPos) then
+      CursorNode := BuildSubTreeAndFindDeepestNodeAtPos(CleanCursorPos, True)
+    else
+      CursorNode := nil;
+
+    if CursorNode = nil then begin
+      // raise exception
+      CursorNode := FindDeepestNodeAtPos(CleanCursorPos, True);
+    end;
+    if CursorNode.Desc = ctnBeginBlock then begin
+      BuildSubTreeForBeginBlock(CursorNode);
+      CursorNode := FindDeepestNodeAtPos(CursorNode, CleanCursorPos, True);
+    end;
+    // set cursor on identifier
+    MoveCursorToCleanPos(CleanCursorPos);
+    if IsDirtySrcValid then begin
+      DirtySrc.SetCursorToIdentStartEndAtPosition;
+      if DirtySrc.CurPos.StartPos >= DirtySrc.CurPos.EndPos then Exit;
+      Identifier := DirtySrc.GetCursorSrcPos;
+    end else begin
+      GetIdentStartEndAtPosition(Src,CleanCursorPos,
+                                 CurPos.StartPos,CurPos.EndPos);
+      if CurPos.StartPos >= CurPos.EndPos then Exit;
+      Identifier := @Src[CurPos.StartPos];
+    end;
+    // find declaration of identifier
+    Params := TFindDeclarationParams.Create;
+    try
+      Params.ContextNode := CursorNode;
+      Params.SetIdentifier(Self, Identifier, nil);
+      Params.Flags := [fdfSearchInParentNodes, fdfTopLvlResolving,
+                       fdfSearchInAncestors, fdfSkipClassForward,
+                       fdfExtractOperand];
+      if ResolveProperty then
+        Include(Params.Flags, fdfPropertyResolving);
+      if FindDeclarationOfIdentAtParam(Params) then
+      begin
+        Operand := Params.ExtractedOperand;
+        Result := Operand <> '';
+      end;
+    finally
+      Params.Free;
+    end;
+  finally
+    ClearIgnoreErrorAfter;
+    DeactivateGlobalWriteLock;
+  end;
+end;
+
 function TFindDeclarationTool.FindIdentifierInProcContext(
   ProcContextNode: TCodeTreeNode;
   Params: TFindDeclarationParams): TIdentifierFoundResult;
@@ -5384,7 +5488,7 @@ begin
   // search identifier in 'with' context
   // Note: do not search in parent nodes (e.g. with ListBox1 do Items)
   Params.Load(OldInput,false);
-  Params.Flags:=Params.Flags-[fdfExceptionOnNotFound,fdfSearchInParentNodes];
+  Params.Flags:=Params.Flags-[fdfExceptionOnNotFound,fdfSearchInParentNodes,fdfExtractOperand];
   Params.ContextNode:=WithVarExpr.Context.Node;
   Result:=WithVarExpr.Context.Tool.FindIdentifierInContext(Params);
   Params.Load(OldInput,true);
@@ -7073,6 +7177,10 @@ var
     {$IFDEF ShowExprEval}
     debugln(['  FindExpressionTypeOfTerm ResolveEdgedBracketOpen']);
     {$ENDIF}
+    if fdfExtractOperand in Params.Flags then begin
+      // extract operand2: [] not implemented yet
+      RaiseException('not implemented');
+    end;
     if (not (NextAtomType in [vatSpace,vatPoint,vatAs,vatUp,vatRoundBracketClose,
       vatRoundBracketOpen,vatEdgedBracketClose,vatEdgedBracketOpen]))
     or ((ExprType.Context.Node=nil)
@@ -10734,6 +10842,13 @@ begin
   end;
 end;
 
+procedure TFindDeclarationParams.AddOperandPart;
+begin
+  if FExtractedOperand <> '' then
+    FExtractedOperand := FExtractedOperand + '.';
+  FExtractedOperand := FExtractedOperand + GetIdentifier(Identifier);
+end;
+
 procedure TFindDeclarationParams.ChangeFoundProc(
   const ProcContext: TFindContext;
   ProcCompatibility: TTypeCompatibility;

components/codetools/pascalparsertool.pas

@@ -213,6 +213,7 @@ type
     procedure ReadVariableType;
     function ReadHintModifier: boolean;
     function ReadTilTypeOfProperty(PropertyNode: TCodeTreeNode): boolean;
+    function ReadTilGetterOfProperty(PropertyNode: TCodeTreeNode): boolean;
     procedure ReadGUID;
     procedure ReadClassInheritance(CreateChildNodes: boolean);
     procedure ReadSpecialize(CreateChildNodes: boolean);
@@ -4930,6 +4931,32 @@ begin
   Result:=true;
 end;
 
+function TPascalParserTool.ReadTilGetterOfProperty(
+  PropertyNode: TCodeTreeNode): boolean;
+begin
+  Result := False;
+  if ReadTilTypeOfProperty(PropertyNode) then begin
+    ReadNextAtom;
+    while CurPos.Flag=cafPoint do begin
+      ReadNextAtom;
+      if not AtomIsIdentifier(False) then Exit;
+      ReadNextAtom;
+    end;
+    if UpAtomIs('INDEX') then begin
+      // read index constant
+      ReadNextAtom;
+      while CurPos.Flag=cafPoint do begin
+        ReadNextAtom;
+        if not AtomIsIdentifier(False) then Exit;
+        ReadNextAtom;
+      end;
+    end;
+    if not UpAtomIs('READ') then Exit;
+    ReadNextAtom;
+    Result := CurPos.StartPos < SrcLen;
+  end;
+end;
+
 procedure TPascalParserTool.ReadGUID;
 
   procedure RaiseStringConstantExpected;