FPDebug: scan in enum / helper to build pascal representation of types

git-svn-id: trunk@43330 -

.gitattributes

@@ -1241,6 +1241,7 @@ components/fpdebug/fpimgreadermacho.pas svneol=native#text/pascal
 components/fpdebug/fpimgreadermachofile.pas svneol=native#text/pascal
 components/fpdebug/fpimgreaderwinpe.pas svneol=native#text/pascal
 components/fpdebug/fpimgreaderwinpetypes.pas svneol=native#text/pascal
+components/fpdebug/fppascalbuilder.pas svneol=native#text/pascal
 components/fpdebug/fppascalparser.pas svneol=native#text/pascal
 components/fpdebug/macho.pas svneol=native#text/pascal
 components/fpdebug/test/FpTest.lpi svneol=native#text/pascal

components/fpdebug/fpdbgclasses.pp

@@ -214,7 +214,7 @@ type
     property Member[AIndex: Integer]: TDbgSymbol read GetMember;
     property MemberByName[AIndex: String]: TDbgSymbol read GetMemberByName; // Includes inheritance
     //
-    property Flags: TDbgSymbolFlags read GetFlags; deprecated;
+    property Flags: TDbgSymbolFlags read GetFlags;
     property Count: Integer read GetCount; deprecated;
     property Reference: TDbgSymbol read GetReference; deprecated;
     property Parent: TDbgSymbol read GetParent; deprecated;

components/fpdebug/fpdbgdwarf.pas

@@ -263,6 +263,7 @@ type
     procedure SetScopeIndex(AValue: Integer);
   protected
     function GoNamedChild(AName: String): Boolean;
+    function GoNamedChildEx(AName: String): Boolean; // find in enum too // TODO: control search with a flags param, if needed
   public
     constructor Create(ACompUnit: TDwarfCompilationUnit; AnInformationEntry: Pointer);
     constructor Create(ACompUnit: TDwarfCompilationUnit; AScope: TDwarfScopeInfo);
@@ -626,6 +627,8 @@ DECL = DW_AT_decl_column, DW_AT_decl_file, DW_AT_decl_line
   { TDbgDwarfTypeIdentifierModifier }
 
   TDbgDwarfTypeIdentifierModifier = class(TDbgDwarfTypeIdentifier)
+  private
+    function NestedHasMembers: Boolean; inline;
   protected
     procedure KindNeeded; override;
     procedure NameNeeded; override;
@@ -1613,6 +1616,11 @@ end;
 
 { TDbgDwarfTypeIdentifierModifier }
 
+function TDbgDwarfTypeIdentifierModifier.NestedHasMembers: Boolean;
+begin
+  Result := (Kind = skClass) or (Kind = skRecord) or (Kind = skEnum);
+end;
+
 procedure TDbgDwarfTypeIdentifierModifier.KindNeeded;
 var
   t: TDbgSymbol;
@@ -1666,12 +1674,14 @@ var
   ti: TDbgSymbol;
 begin
   ti := nil;
-  if (Kind = skClass) or (Kind = skRecord) then
+  if NestedHasMembers then begin
     ti := NestedTypeInfo;
-  if ti <> nil then
-    Result := ti.Member[AIndex]
-  else
-    Result := inherited GetMember(AIndex);
+    if ti <> nil then begin
+      Result := ti.Member[AIndex];
+      exit;
+    end;
+  end;
+  Result := inherited GetMember(AIndex);
 end;
 
 function TDbgDwarfTypeIdentifierModifier.GetMemberByName(AIndex: String): TDbgSymbol;
@@ -1679,12 +1689,14 @@ var
   ti: TDbgSymbol;
 begin
   ti := nil;
-  if (Kind = skClass) or (Kind = skRecord) then
+  if NestedHasMembers then begin
     ti := NestedTypeInfo;
-  if ti <> nil then
-    Result := ti.MemberByName[AIndex]
-  else
-    Result := inherited GetMemberByName(AIndex);
+    if ti <> nil then begin
+      Result := ti.MemberByName[AIndex];
+      exit;
+    end;
+  end;
+  Result := inherited GetMemberByName(AIndex);
 end;
 
 function TDbgDwarfTypeIdentifierModifier.GetMemberCount: Integer;
@@ -1692,12 +1704,14 @@ var
   ti: TDbgSymbol;
 begin
   ti := nil;
-  if (Kind = skClass) or (Kind = skRecord) then
+  if NestedHasMembers then begin
     ti := NestedTypeInfo;
-  if ti <> nil then
-    Result := ti.MemberCount
-  else
-    Result := inherited GetMemberCount;
+    if ti <> nil then begin
+      Result := ti.MemberCount;
+      exit;
+    end;
+  end;
+  Result := inherited GetMemberCount;
 end;
 
 { TDbgDwarfBaseTypeIdentifier }
@@ -1870,8 +1884,10 @@ end;
 function TDwarfInformationEntry.GoNamedChild(AName: String): Boolean;
 var
   EntryName: String;
+  s: String;
 begin
   Result := False;
+  s := UpperCase(AName);
   GoChild;
   while HasValidScope do begin
     if not ReadValue(DW_AT_name, EntryName) then begin
@@ -1879,7 +1895,7 @@ begin
       Continue;
     end;
 
-    if UpperCase(EntryName) = UpperCase(AName) then begin
+    if UpperCase(EntryName) = s then begin
       // TODO: check DW_AT_start_scope;
       DebugLn([FPDBG_DWARF_SEARCH, 'GoNamedChild found ', dbgs(FScope, FCompUnit), DbgSName(Self)]);
       Result := True;
@@ -1890,6 +1906,52 @@ begin
   end;
 end;
 
+function TDwarfInformationEntry.GoNamedChildEx(AName: String): Boolean;
+var
+  EntryName: String;
+  s: String;
+  InEnum: Boolean;
+begin
+  Result := False;
+  InEnum := False;
+  s := UpperCase(AName);
+  GoChild;
+  while true do begin
+    while HasValidScope do begin
+      if not ReadValue(DW_AT_name, EntryName) then begin
+        GoNext;
+        Continue;
+      end;
+
+      if UpperCase(EntryName) = s then begin
+        // TODO: check DW_AT_start_scope;
+        DebugLn([FPDBG_DWARF_SEARCH, 'GoNamedChildEx found ', dbgs(FScope, FCompUnit), DbgSName(Self)]);
+        Result := True;
+        exit;
+      end;
+
+      // Abbrev was prelaped by ReadName
+      if Abbrev.tag = DW_TAG_enumeration_type then begin
+        assert(not InEnum, 'nested enum');
+        InEnum := True;
+        GoChild;
+        Continue;
+      end;
+
+
+      GoNext;
+    end;
+
+    if InEnum then begin
+      InEnum := False;
+      GoParent;
+      GoNext;
+      continue;
+    end;
+    break;
+  end;
+end;
+
 constructor TDwarfInformationEntry.Create(ACompUnit: TDwarfCompilationUnit;
   AnInformationEntry: Pointer);
 begin
@@ -3273,7 +3335,7 @@ begin
       debugln(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier Searching ', dbgs(InfoEntry.FScope, CU)]);
       StartScopeIdx := InfoEntry.ScopeIndex;
 
-      if InfoEntry.GoNamedChild(AName) then begin
+      if InfoEntry.GoNamedChildEx(AName) then begin
         Result := TDbgDwarfIdentifier.CreateSubClass(AName, InfoEntry);
         DebugLn(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier found ', dbgs(InfoEntry.FScope, CU), DbgSName(Result)]);
         break;

components/fpdebug/fpdebug.lpk

@@ -34,7 +34,7 @@ File(s) with other licenses (see also header in file(s):
 
   (Any modifications/translations of this file are from duby)
 "/>
-    <Files Count="17">
+    <Files Count="18">
       <Item1>
         <Filename Value="fpdbgclasses.pp"/>
         <UnitName Value="FpDbgClasses"/>
@@ -103,6 +103,10 @@ File(s) with other licenses (see also header in file(s):
         <Filename Value="fpimgreadermacho.pas"/>
         <UnitName Value="FpImgReaderMacho"/>
       </Item17>
+      <Item18>
+        <Filename Value="fppascalbuilder.pas"/>
+        <UnitName Value="fppascalbuilder"/>
+      </Item18>
     </Files>
     <Type Value="RunAndDesignTime"/>
     <RequiredPkgs Count="2">

components/fpdebug/fpdebug.pas

@@ -10,7 +10,7 @@ uses
   FpDbgClasses, FpDbgDisasX86, FpDbgDwarf, FpDbgDwarfConst, FpDbgLoader, FpDbgPETypes, 
   FpDbgSymbols, FpDbgUtil, FpDbgWinExtra, FpImgReaderWinPE, FpImgReaderElf, 
   FpImgReaderElfTypes, FpImgReaderBase, FpPascalParser, macho, FpImgReaderMachoFile, 
-  FpImgReaderMacho, LazarusPackageIntf;
+  FpImgReaderMacho, FpPascalBuilder, LazarusPackageIntf;
 
 implementation
 

components/fpdebug/fppascalbuilder.pas

@@ -0,0 +1,236 @@
+unit FpPascalBuilder;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, FpDbgClasses;
+
+type
+  TTypeNameFlag = (
+    tnfOnlyDeclared,    // do not return a substitute with ^ symbol
+    tnfIncludeOneRef    // If it is a pointer, and the pointed-to name is known, return ^TXxx
+                        //   without tnfOnlyDeclared, may return ^^^TXxx if needed
+
+  );
+  TTypeNameFlags = set of TTypeNameFlag;
+
+  TTypeDeclarationFlag = (
+    tdfIncludeVarName,   // like i: Integer
+    tdfSkipClassBody     // shorten class
+  );
+  TTypeDeclarationFlags = set of TTypeDeclarationFlag;
+
+function GetTypeName(out ATypeName: String; ADbgSymbol: TDbgSymbol; AFlags: TTypeNameFlags = []): Boolean;
+function GetTypeAsDeclaration(out ATypeDeclaration: String; ADbgSymbol: TDbgSymbol;
+  AFlags: TTypeDeclarationFlags = []; AnIndent: Integer = 0): Boolean;
+
+implementation
+
+function GetTypeName(out ATypeName: String; ADbgSymbol: TDbgSymbol;
+  AFlags: TTypeNameFlags): Boolean;
+var
+  s: String;
+begin
+  Result := ADbgSymbol <> nil;
+  if not Result then
+    exit;
+  if ADbgSymbol.SymbolType = stValue then begin
+    ADbgSymbol := ADbgSymbol.TypeInfo;
+    Result := ADbgSymbol <> nil;
+    if not Result then
+      exit;
+  end;
+
+  ATypeName := ADbgSymbol.Name;
+  Result := ATypeName <> '';
+
+  if (tnfIncludeOneRef in AFlags) or
+     ((not Result) and (not (tnfOnlyDeclared in AFlags)))
+  then begin
+    ATypeName := '^';
+    while ADbgSymbol.Kind = skPointer do begin
+      ADbgSymbol := ADbgSymbol.TypeInfo;
+      s := ADbgSymbol.Name;
+      if s <> '' then begin
+        ATypeName := ATypeName + s;
+        Result := True;
+        exit;
+      end;
+
+      if (tnfOnlyDeclared in AFlags) then // only one level
+        exit;
+      ATypeName := ATypeName + '^';
+    end;
+
+    Result := False;
+  end;
+
+end;
+
+function GetTypeAsDeclaration(out ATypeDeclaration: String; ADbgSymbol: TDbgSymbol;
+  AFlags: TTypeDeclarationFlags; AnIndent: Integer): Boolean;
+var
+  IndentString: String;
+
+  function GetIndent: String;
+  begin
+    if (IndentString = '') and (AnIndent > 0) then
+      IndentString := StringOfChar(' ', AnIndent);
+    Result := IndentString;
+  end;
+
+  Function MembersAsGdbText(out AText: String; WithVisibilty: Boolean; AFlags: TTypeDeclarationFlags = []): Boolean;
+  var
+    CurVis: TDbgSymbolMemberVisibility;
+
+    procedure AddVisibility(AVis: TDbgSymbolMemberVisibility; AFirst: Boolean);
+    begin
+      if not (WithVisibilty and ((CurVis <> AVis) or AFirst)) then
+        exit;
+      CurVis := AVis;
+      case AVis of
+        svPrivate:   AText := AText + GetIndent + '  private' + LineEnding;
+        svProtected: AText := AText + GetIndent + '  protected' + LineEnding;
+        svPublic:    AText := AText + GetIndent + '  public' + LineEnding;
+      end;
+    end;
+
+  var
+    c, i: Integer;
+    m: TDbgSymbol;
+    s: String;
+  begin
+    Result := True;
+    AText := '';
+    c := ADbgSymbol.MemberCount;
+    i := 0;
+    while (i < c) and Result do begin
+      m := ADbgSymbol.Member[i];
+      AddVisibility(m.MemberVisibility, i= 0);
+      Result := GetTypeAsDeclaration(s, m, [tdfIncludeVarName] + AFlags, AnIndent + 4);
+      if Result then
+        AText := AText + GetIndent + s + ';' + LineEnding;
+      inc(i);
+    end;
+  end;
+
+  function GetPointerType(out ADeclaration: String): Boolean;
+  var
+    s: String;
+  begin
+    s := '';
+    while ADbgSymbol.Kind = skPointer do begin
+      ADbgSymbol := ADbgSymbol.TypeInfo;
+      s := s + '^';
+    end;
+    Result := GetTypeName(ADeclaration, ADbgSymbol, []);
+// TODO brackets
+    ADeclaration := s + ADeclaration;
+  end;
+
+  function GetBaseType(out ADeclaration: String): Boolean;
+  begin
+    Result := GetTypeName(ADeclaration, ADbgSymbol, []);
+  end;
+
+  function GetFunctionType(out ADeclaration: String): Boolean;
+  var
+    s: String;
+  begin
+    // Todo param
+    GetTypeAsDeclaration(s, ADbgSymbol.TypeInfo);
+    ADeclaration := 'function ' + ADbgSymbol.Name + ' () : ' + s + '';
+    if sfVirtual in ADbgSymbol.Flags then ADeclaration := ADeclaration + '; virtual';
+    Result := true;
+  end;
+
+  function GetProcedureType(out ADeclaration: String): Boolean;
+  begin
+    // Todo param
+    ADeclaration := 'procedure ' + ADbgSymbol.Name + ' ()';
+    if sfVirtual in ADbgSymbol.Flags then ADeclaration := ADeclaration + '; virtual';
+    Result := true;
+  end;
+
+  function GetClassType(out ADeclaration: String): Boolean;
+  var
+    s, s2: String;
+  begin
+    Result := tdfSkipClassBody in AFlags;
+    if Result then begin
+      GetTypeName(s, ADbgSymbol);
+      ADeclaration := s + ' {=class}';
+      exit;
+    end;
+    Result := MembersAsGdbText(s, True, [tdfSkipClassBody]);
+    GetTypeName(s2, ADbgSymbol.TypeInfo);
+    if Result then
+      ADeclaration := Format('class(%s)%s%s%send%s',
+                             [s2, LineEnding, s, LineEnding, GetIndent]);
+  end;
+
+  function GetRecordType(out ADeclaration: String): Boolean;
+  var
+    s: String;
+  begin
+    Result := MembersAsGdbText(s, True);
+    if Result then
+      ADeclaration := Format('record%s%s%send%s', [LineEnding, s, LineEnding, GetIndent]);
+  end;
+
+  function GetEnumType(out ADeclaration: String): Boolean;
+  var
+    i: Integer;
+    m: TDbgSymbol;
+  begin
+    // TODO assigned value (a,b:=3,...)
+    Result := True;
+    ADeclaration := '(';
+    for i := 0 to ADbgSymbol.MemberCount - 1 do begin
+      m := ADbgSymbol.Member[i];
+      if i > 0 then ADeclaration := ADeclaration + ', ';
+      ADeclaration := ADeclaration + m.Name;
+    end;
+    ADeclaration := ADeclaration + ')'
+  end;
+
+var
+  VarName: String;
+begin
+  Result := ADbgSymbol <> nil;
+  if not Result then
+    exit;
+  VarName := '';
+  if (ADbgSymbol.SymbolType = stValue) and
+     not((ADbgSymbol.Kind = skProcedure) or (ADbgSymbol.Kind = skFunction))
+  then begin
+    if tdfIncludeVarName in AFlags then
+      VarName := ADbgSymbol.Name;
+    ADbgSymbol := ADbgSymbol.TypeInfo;
+    Result := ADbgSymbol <> nil;
+    if not Result then
+      exit;
+  end;
+
+  case ADbgSymbol.Kind of
+    skPointer:   Result := GetPointerType(ATypeDeclaration);
+    skInteger, skCardinal, skBoolean, skChar, skFloat:
+                 Result := GetBaseType(ATypeDeclaration);
+    skFunction:  Result := GetFunctionType(ATypeDeclaration);
+    skProcedure: Result := GetProcedureType(ATypeDeclaration);
+    skClass:     Result := GetClassType(ATypeDeclaration);
+    skRecord:    Result := GetRecordType(ATypeDeclaration);
+    skEnum:      Result := GetEnumType(ATypeDeclaration);
+  end;
+
+  if VarName <> '' then
+    ATypeDeclaration := VarName + ': ' + ATypeDeclaration;
+  if AnIndent <> 0 then
+    ATypeDeclaration := GetIndent + ATypeDeclaration;
+end;
+
+
+end.
+