unit FpDbgDwarfFreePascal;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Types, math, FpDbgDwarfDataClasses, FpDbgDwarf, FpDbgInfo,
  FpDbgUtil, FpDbgDwarfConst, FpErrorMessages, FpdMemoryTools, DbgIntfBaseTypes,
  LazLoggerBase;

type

  {%Region * ***** SymbolClassMap ***** *}

  { TFpDwarfFreePascalSymbolClassMap }

  TFpDwarfFreePascalSymbolClassMap = class(TFpDwarfDefaultSymbolClassMap)
  strict private
    class var ExistingClassMap: TFpSymbolDwarfClassMap;
  protected
    class function GetExistingClassMap: PFpDwarfSymbolClassMap; override;
  public
    class function ClassCanHandleCompUnit(ACU: TDwarfCompilationUnit): Boolean; override;
  public
    function GetDwarfSymbolClass(ATag: Cardinal): TDbgDwarfSymbolBaseClass; override;
    function CreateContext(AThreadId, AStackFrame: Integer; AnAddress: TDBGPtr; ASymbol: TFpSymbol;
      ADwarf: TFpDwarfInfo): TFpDbgInfoContext; override;
    //class function CreateProcSymbol(ACompilationUnit: TDwarfCompilationUnit;
    //  AInfo: PDwarfAddressInfo; AAddress: TDbgPtr): TDbgDwarfSymbolBase; override;
  end;

  { TFpDwarfFreePascalSymbolClassMapDwarf2 }

  TFpDwarfFreePascalSymbolClassMapDwarf2 = class(TFpDwarfFreePascalSymbolClassMap)
  strict private
    class var ExistingClassMap: TFpSymbolDwarfClassMap;
  protected
    class function GetExistingClassMap: PFpDwarfSymbolClassMap; override;
  public
    class function ClassCanHandleCompUnit(ACU: TDwarfCompilationUnit): Boolean; override;
  public
    function GetDwarfSymbolClass(ATag: Cardinal): TDbgDwarfSymbolBaseClass; override;
    //class function CreateContext(AThreadId, AStackFrame: Integer; AnAddress: TDBGPtr; ASymbol: TFpSymbol;
    //  ADwarf: TFpDwarfInfo): TFpDbgInfoContext; override;
    //class function CreateProcSymbol(ACompilationUnit: TDwarfCompilationUnit;
    //  AInfo: PDwarfAddressInfo; AAddress: TDbgPtr): TDbgDwarfSymbolBase; override;
  end;

  { TFpDwarfFreePascalSymbolClassMapDwarf3 }

  TFpDwarfFreePascalSymbolClassMapDwarf3 = class(TFpDwarfFreePascalSymbolClassMap)
  strict private
    class var ExistingClassMap: TFpSymbolDwarfClassMap;
  private
    FCompilerVersion: Cardinal;
  protected
    function CanHandleCompUnit(ACU: TDwarfCompilationUnit; AHelperData: Pointer): Boolean; override;
    class function GetExistingClassMap: PFpDwarfSymbolClassMap; override;
  public
    class function GetInstanceForCompUnit(ACU: TDwarfCompilationUnit): TFpSymbolDwarfClassMap; override;
    class function ClassCanHandleCompUnit(ACU: TDwarfCompilationUnit): Boolean; override;
  public
    constructor Create(ACU: TDwarfCompilationUnit; AHelperData: Pointer); override;
    function GetDwarfSymbolClass(ATag: Cardinal): TDbgDwarfSymbolBaseClass; override;
    //class function CreateContext(AThreadId, AStackFrame: Integer; AnAddress: TDBGPtr; ASymbol: TFpSymbol;
    //  ADwarf: TFpDwarfInfo): TFpDbgInfoContext; override;
    //class function CreateProcSymbol(ACompilationUnit: TDwarfCompilationUnit;
    //  AInfo: PDwarfAddressInfo; AAddress: TDbgPtr): TDbgDwarfSymbolBase; override;
  end;

  {%EndRegion }

  {%Region * ***** Context ***** *}

  { TFpDwarfFreePascalAddressContext }

  TFpDwarfFreePascalAddressContext = class(TFpDwarfInfoAddressContext)
  private
    FOuterNestContext: TFpDbgInfoContext;
    FOuterNotFound: Boolean;
  protected
    function FindLocalSymbol(const AName: String; PNameUpper, PNameLower: PChar;
      InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpValue): Boolean; override;
  public
    destructor Destroy; override;
  end;

  {%EndRegion }

  {%Region * ***** Value & Types ***** *}

  (* *** Class vs ^Record vs ^Object *** *)

  { TFpSymbolDwarfFreePascalTypeDeclaration }

  TFpSymbolDwarfFreePascalTypeDeclaration = class(TFpSymbolDwarfTypeDeclaration)
  protected
   // fpc encodes classes as pointer, not ref (so Obj1 = obj2 compares the pointers)
   // typedef > pointer > srtuct
   // while a pointer to class/object: pointer > typedef > ....
    function DoGetNestedTypeInfo: TFpSymbolDwarfType; override;
  end;

  { TFpSymbolDwarfFreePascalTypePointer }

  TFpSymbolDwarfFreePascalTypePointer = class(TFpSymbolDwarfTypePointer)
  private
    FIsInternalPointer: Boolean;
    function GetIsInternalPointer: Boolean; inline;
    function IsInternalDynArrayPointer: Boolean; inline;
  protected
    procedure TypeInfoNeeded; override;
    procedure KindNeeded; override;
    procedure ForwardToSymbolNeeded; override;
    function GetDataAddressNext(AValueObj: TFpValueDwarf; var AnAddress: TFpDbgMemLocation;
                            ATargetType: TFpSymbolDwarfType; ATargetCacheIndex: Integer): Boolean; override;
    function GetTypedValueObject(ATypeCast: Boolean): TFpValueDwarf; override;
    function DataSize: Integer; override;
  public
    property IsInternalPointer: Boolean read GetIsInternalPointer write FIsInternalPointer; // Class (also DynArray, but DynArray is handled without this)
  end;

  { TFpSymbolDwarfFreePascalTypeStructure }

  TFpSymbolDwarfFreePascalTypeStructure = class(TFpSymbolDwarfTypeStructure)
  protected
    procedure KindNeeded; override;
  end;

  (* *** Record vs ShortString *** *)

  { TFpSymbolDwarfV2FreePascalTypeStructure }

  TFpSymbolDwarfV2FreePascalTypeStructure = class(TFpSymbolDwarfTypeStructure)
  private
    FIsShortString: (issUnknown, issShortString, issStructure);
    function IsShortString: Boolean;
  protected
    function GetTypedValueObject(ATypeCast: Boolean): TFpValueDwarf; override;
    procedure KindNeeded; override;
    function GetNestedSymbolCount: Integer; override;
    //function GetNestedSymbolByName(AIndex: String): TFpSymbol; override;
  end;

  { TFpValueDwarfV2FreePascalShortString }

  TFpValueDwarfV2FreePascalShortString = class(TFpValueDwarf)
  protected
    function IsValidTypeCast: Boolean; override;
    function GetInternMemberByName(AIndex: String): TFpValue;
    procedure Reset; override;
  private
    FValue: String;
    FValueDone: Boolean;
  protected
    function GetFieldFlags: TFpValueFieldFlags; override;
    function GetAsString: AnsiString; override;
    function GetAsWideString: WideString; override;
  end;

  (* *** "Open Array" in params *** *)

  { TFpSymbolDwarfFreePascalSymbolTypeArray }

  TFpSymbolDwarfFreePascalSymbolTypeArray = class(TFpSymbolDwarfTypeArray)
  protected
    function GetTypedValueObject(ATypeCast: Boolean): TFpValueDwarf; override;
  end;

  { TFpValueDwarfFreePascalArray }

  TFpValueDwarfFreePascalArray = class(TFpValueDwarfArray)
  protected
    function GetMemberCount: Integer; override;
  end;

  (* *** Array vs AnsiString *** *)

  { TFpSymbolDwarfV3FreePascalSymbolTypeArray }

  TFpSymbolDwarfV3FreePascalSymbolTypeArray = class(TFpSymbolDwarfFreePascalSymbolTypeArray)
  private type
    TArrayOrStringType = (iasUnknown, iasArray, iasShortString, iasAnsiString, iasUnicodeString);
  private
    FArrayOrStringType: TArrayOrStringType;
    function GetInternalStringType: TArrayOrStringType;
  protected
    function GetTypedValueObject(ATypeCast: Boolean): TFpValueDwarf; override;
    procedure KindNeeded; override;
  end;

  { TFpValueDwarfV3FreePascalString }

  TFpValueDwarfV3FreePascalString = class(TFpValueDwarf) // short & ansi...
  private
    FValue: String;
    FValueDone: Boolean;
  protected
    function IsValidTypeCast: Boolean; override;
    procedure Reset; override;
    function GetFieldFlags: TFpValueFieldFlags; override;
    function GetAsString: AnsiString; override;
    function GetAsWideString: WideString; override;
  end;

  {%EndRegion }

implementation

{ TFpSymbolDwarfFreePascalTypeStructure }

procedure TFpSymbolDwarfFreePascalTypeStructure.KindNeeded;
begin
  if (InformationEntry.AbbrevTag = DW_TAG_class_type) then
    SetKind(skClass)
  else
  begin
    if TypeInfo <> nil then // inheritance
      SetKind(skObject) // skClass
    else
    if NestedSymbolByName['_vptr$TOBJECT'] <> nil then
      SetKind(skObject) // skClass
    else
    if NestedSymbolByName['_vptr$'+Name] <> nil then
      SetKind(skObject)
    else
      SetKind(skRecord);
  end;
end;

{ TFpDwarfFreePascalSymbolClassMap }

class function TFpDwarfFreePascalSymbolClassMap.GetExistingClassMap: PFpDwarfSymbolClassMap;
begin
  Result := @ExistingClassMap;
end;

class function TFpDwarfFreePascalSymbolClassMap.ClassCanHandleCompUnit(ACU: TDwarfCompilationUnit): Boolean;
var
  s: String;
begin
  s := LowerCase(ACU.Producer);
  Result := pos('free pascal', s) > 0;
end;

function TFpDwarfFreePascalSymbolClassMap.GetDwarfSymbolClass(
  ATag: Cardinal): TDbgDwarfSymbolBaseClass;
begin
  case ATag of
    DW_TAG_typedef:          Result := TFpSymbolDwarfFreePascalTypeDeclaration;
    DW_TAG_pointer_type:     Result := TFpSymbolDwarfFreePascalTypePointer;
    DW_TAG_class_type:       Result := TFpSymbolDwarfFreePascalTypeStructure;
    DW_TAG_array_type:       Result := TFpSymbolDwarfFreePascalSymbolTypeArray;
    else                     Result := inherited GetDwarfSymbolClass(ATag);
  end;
end;

function TFpDwarfFreePascalSymbolClassMap.CreateContext(AThreadId, AStackFrame: Integer;
  AnAddress: TDBGPtr; ASymbol: TFpSymbol; ADwarf: TFpDwarfInfo): TFpDbgInfoContext;
begin
  Result := TFpDwarfFreePascalAddressContext.Create(AThreadId, AStackFrame, AnAddress, ASymbol, ADwarf);
end;

{ TFpDwarfFreePascalSymbolClassMapDwarf2 }

class function TFpDwarfFreePascalSymbolClassMapDwarf2.GetExistingClassMap: PFpDwarfSymbolClassMap;
begin
  Result := @ExistingClassMap;
end;

class function TFpDwarfFreePascalSymbolClassMapDwarf2.ClassCanHandleCompUnit(
  ACU: TDwarfCompilationUnit): Boolean;
begin
  Result := inherited ClassCanHandleCompUnit(ACU);
  Result := Result and (ACU.Version < 3);
end;

function TFpDwarfFreePascalSymbolClassMapDwarf2.GetDwarfSymbolClass(
  ATag: Cardinal): TDbgDwarfSymbolBaseClass;
begin
  case ATag of
    DW_TAG_structure_type:
      Result := TFpSymbolDwarfV2FreePascalTypeStructure; // maybe record
  //  // TODO:
  //  //DW_TAG_reference_type:   Result := TFpSymbolDwarfTypeRef;
  //  //DW_TAG_typedef:          Result := TFpSymbolDwarfTypeDeclaration;
  //  //DW_TAG_pointer_type:     Result := TFpSymbolDwarfTypePointer;
  //  //
  //  //DW_TAG_base_type:        Result := TFpSymbolDwarfTypeBasic;
  //  //DW_TAG_subrange_type:    Result := TFpSymbolDwarfTypeSubRange;
  //  //DW_TAG_enumeration_type: Result := TFpSymbolDwarfTypeEnum;
  //  //DW_TAG_enumerator:       Result := TFpSymbolDwarfDataEnumMember;
  //  //DW_TAG_array_type:       Result := TFpSymbolDwarfTypeArray;
  //  ////
  //  //DW_TAG_compile_unit:     Result := TFpSymbolDwarfUnit;
  //
    else
      Result := inherited GetDwarfSymbolClass(ATag);
  end;
end;

{ TFpDwarfFreePascalSymbolClassMapDwarf3 }

function TFpDwarfFreePascalSymbolClassMapDwarf3.CanHandleCompUnit(
  ACU: TDwarfCompilationUnit; AHelperData: Pointer): Boolean;
begin
  Result := (FCompilerVersion = PtrUInt(AHelperData)) and
            inherited CanHandleCompUnit(ACU, AHelperData);
end;

class function TFpDwarfFreePascalSymbolClassMapDwarf3.GetExistingClassMap: PFpDwarfSymbolClassMap;
begin
  Result := @ExistingClassMap;
end;

class function TFpDwarfFreePascalSymbolClassMapDwarf3.GetInstanceForCompUnit(
  ACU: TDwarfCompilationUnit): TFpSymbolDwarfClassMap;
var
  s: String;
  i, j, v: Integer;
begin
  s := LowerCase(ACU.Producer)+' ';
  v := 0;
  i := pos('free pascal', s) + 11;
  if i > 11 then begin
    while (i < Length(s)) and (s[i] in [' ', #9]) do
      inc(i);
    delete(s, 1, i - 1);
    i := pos('.', s);
    if (i > 1) then begin
      j := StrToIntDef(copy(s, 1, i - 1), 0);
      if (j >= 0) then
        v := j * $10000;
      delete(s, 1, i);
    end;
    if (v > 0) then begin
      i := pos('.', s);
      if (i > 1) then begin
        j := StrToIntDef(copy(s, 1, i - 1), 0);
        if (j >= 0) and (j < 99) then
          v := v + j * $100
        else
          v := 0;
        delete(s, 1, i);
      end;
    end;
    if (v > 0) then begin
      i := pos(' ', s);
      if (i > 1) then begin
        j := StrToIntDef(copy(s, 1, i - 1), 0);
        if (j >= 0) and (j < 99) then
          v := v + j
        else
          v := 0;
      end;
    end;
  end;

  Result := DoGetInstanceForCompUnit(ACU, Pointer(PtrUInt(v)));
end;

class function TFpDwarfFreePascalSymbolClassMapDwarf3.ClassCanHandleCompUnit(
  ACU: TDwarfCompilationUnit): Boolean;
begin
  Result := inherited ClassCanHandleCompUnit(ACU);
  Result := Result and (ACU.Version >= 3);
end;

constructor TFpDwarfFreePascalSymbolClassMapDwarf3.Create(
  ACU: TDwarfCompilationUnit; AHelperData: Pointer);
begin
  FCompilerVersion := PtrUInt(AHelperData);
  inherited;
end;

function TFpDwarfFreePascalSymbolClassMapDwarf3.GetDwarfSymbolClass(
  ATag: Cardinal): TDbgDwarfSymbolBaseClass;
begin
  case ATag of
    DW_TAG_array_type:
      Result := TFpSymbolDwarfV3FreePascalSymbolTypeArray;
  //  DW_TAG_structure_type:
  //    Result := TFpSymbolDwarfV2FreePascalTypeStructure; // maybe record
  //  // TODO:
  //  //DW_TAG_reference_type:   Result := TFpSymbolDwarfTypeRef;
  //  //DW_TAG_typedef:          Result := TFpSymbolDwarfTypeDeclaration;
  //  //DW_TAG_pointer_type:     Result := TFpSymbolDwarfTypePointer;
  //  //
  //  //DW_TAG_base_type:        Result := TFpSymbolDwarfTypeBasic;
  //  //DW_TAG_subrange_type:    Result := TFpSymbolDwarfTypeSubRange;
  //  //DW_TAG_enumeration_type: Result := TFpSymbolDwarfTypeEnum;
  //  //DW_TAG_enumerator:       Result := TFpSymbolDwarfDataEnumMember;
  //  //DW_TAG_array_type:       Result := TFpSymbolDwarfTypeArray;
  //  ////
  //  //DW_TAG_compile_unit:     Result := TFpSymbolDwarfUnit;
  //
    else
      Result := inherited GetDwarfSymbolClass(ATag);
  end;
end;

{ TFpDwarfFreePascalAddressContext }

function TFpDwarfFreePascalAddressContext.FindLocalSymbol(const AName: String; PNameUpper,
  PNameLower: PChar; InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpValue): Boolean;
const
  parentfp: string = 'parentfp';
  parentfp2: string = '$parentfp';
  selfname: string = 'self';
  // TODO: get reg num via memreader name-to-num
  RegFp64 = 6;
  RegPc64 = 16;
  RegFp32 = 5;
  RegPc32 = 8;
var
  StartScopeIdx, RegFp, RegPc: Integer;
  ParentFpVal: TFpValue;
  SearchCtx: TFpDwarfFreePascalAddressContext;
  par_fp, cur_fp, prev_fp, pc: TDbgPtr;
  d, i: Integer;
  ParentFpSym: TFpSymbolDwarf;
begin
  if Dwarf.Image64Bit then begin
    RegFP := RegFp64;
    RegPc := RegPc64;
  end
  else begin
    RegFP := RegFp32;
    RegPc := RegPc32;
  end;
  Result := False;
  if (Length(AName) = length(selfname)) and (CompareUtf8BothCase(PNameUpper, PNameLower, @selfname[1])) then begin
    ADbgValue := GetSelfParameter;
    if ADbgValue <> nil then begin
      AddRefToVal(ADbgValue);
      Result := True;
      exit;
    end;
  end;

  StartScopeIdx := InfoEntry.ScopeIndex;
  Result := inherited FindLocalSymbol(AName, PNameUpper, PNameLower, InfoEntry, ADbgValue);
  if Result then
    exit;

  if FOuterNotFound then
    exit;

  if FOuterNestContext <> nil then begin
    ADbgValue := FOuterNestContext.FindSymbol(AName); // TODO: pass upper/lower
    if ADbgValue <> nil then
      AddRefToVal(ADbgValue);
    Result := True; // self, global was done by outer
    exit;
  end;


  InfoEntry.ScopeIndex := StartScopeIdx;
  if not InfoEntry.GoNamedChildEx(@parentfp[1], @parentfp[1]) then begin
    InfoEntry.ScopeIndex := StartScopeIdx;
    if not InfoEntry.GoNamedChildEx(@parentfp2[1], @parentfp2[1]) then begin
      FOuterNotFound := True;
      exit;
    end;
  end;

  ParentFpSym := TFpSymbolDwarf.CreateSubClass(AName, InfoEntry);
  ParentFpVal := ParentFpSym.Value;
  ApplyContext(ParentFpVal);
  //TFpSymbolDwarf(ADbgValue.DbgSymbol).ParentTypeInfo := TFpSymbolDwarfDataProc(FSymbol);
  if not (svfOrdinal in ParentFpVal.FieldFlags) then begin
    DebugLn('no ordinal for parentfp');
    ParentFpSym.ReleaseReference;
    FOuterNotFound := True;
    exit;
  end;

  par_fp := ParentFpVal.AsCardinal;
  ParentFpSym.ReleaseReference;
    DebugLn(['par_fp=',par_fp]);
  if par_fp = 0 then begin
    DebugLn('no ordinal for parentfp');
    FOuterNotFound := True;
    exit;
  end;

  i := StackFrame + 1;
  SearchCtx := TFpDwarfFreePascalAddressContext.Create(ThreadId, i, 0, Symbol, Dwarf);

  cur_fp := 0;
  if MemManager.ReadRegister(RegFp, cur_fp, Self) then begin
    if cur_fp > par_fp then
      d := -1  // cur_fp must go down
    else
      d := 1;  // cur_fp must go up
    while not (cur_fp = par_fp) do begin
      SearchCtx.StackFrame := i;
      // TODO: get reg num via memreader name-to-num
      prev_fp := cur_fp;
      if not MemManager.ReadRegister(RegFp, cur_fp, SearchCtx) then
        break;
      inc(i);
      if (cur_fp = prev_fp) or ((cur_fp < prev_fp) xor (d = -1)) then
        break;  // wrong direction
      if i > StackFrame + 200 then break; // something wrong? // TODO better check
    end;
    dec(i);
  end;

  if (par_fp <> cur_fp) or (cur_fp = 0) or
      not MemManager.ReadRegister(RegPc, pc, SearchCtx)
  then begin
    FOuterNotFound := True;
    SearchCtx.ReleaseReference;
    exit;
  end;

  SearchCtx.ReleaseReference;

  FOuterNestContext := Dwarf.FindContext(ThreadId, i, pc);

  ADbgValue := FOuterNestContext.FindSymbol(AName); // TODO: pass upper/lower
  if ADbgValue <> nil then
    AddRefToVal(ADbgValue);
  Result := True; // self, global was done by outer
end;

destructor TFpDwarfFreePascalAddressContext.Destroy;
begin
  FOuterNestContext.ReleaseReference;
  inherited Destroy;
end;

{ TFpSymbolDwarfV2FreePascalTypeStructure }

function TFpSymbolDwarfV2FreePascalTypeStructure.IsShortString: Boolean;
var
  LenSym, StSym, StSymType: TFpSymbol;
begin
  if FIsShortString <> issUnknown then
    exit(FIsShortString = issShortString);

  Result := False;
  FIsShortString := issStructure;
  if (inherited NestedSymbolCount <> 2) then
    exit;

  LenSym := inherited NestedSymbolByName['length'];
  if (LenSym = nil) or (LenSym.Kind <> skCardinal) // or (LenSym.Size <> 1) // not implemented yet
  then
    exit;

  StSym := inherited NestedSymbolByName['st'];
  if (StSym = nil) then
    exit;
  StSymType := StSym.TypeInfo;
  if (StSymType = nil) or (StSymType.Kind <> skArray) or not (StSymType is TFpSymbolDwarfTypeArray) then
    exit;

  // If it were a user declared array, fpc puts the stride in the subrange
  if not TFpSymbolDwarfTypeArray(StSymType).InformationEntry.HasAttrib(DW_AT_byte_stride) then
    exit;
  // check the subrange?

  FIsShortString := issShortString;
  Result := True;
end;

function TFpSymbolDwarfV2FreePascalTypeStructure.GetTypedValueObject(
  ATypeCast: Boolean): TFpValueDwarf;
begin
  if not IsShortString then
    Result := inherited GetTypedValueObject(ATypeCast)
  else
    Result := TFpValueDwarfV2FreePascalShortString.Create(Self);
end;

procedure TFpSymbolDwarfV2FreePascalTypeStructure.KindNeeded;
begin
  if not IsShortString then
    inherited KindNeeded
  else
    SetKind(skString);
end;

function TFpSymbolDwarfV2FreePascalTypeStructure.GetNestedSymbolCount: Integer;
begin
  if IsShortString then
    Result := 0
  else
    Result := inherited GetNestedSymbolCount;
end;

{ TFpSymbolDwarfFreePascalTypeDeclaration }

function TFpSymbolDwarfFreePascalTypeDeclaration.DoGetNestedTypeInfo: TFpSymbolDwarfType;
var
  ti: TFpSymbolDwarfType;
  ti2: TFpSymbol;
begin
  Result := inherited DoGetNestedTypeInfo;

  // Is internal class pointer?
  // Do not trigged any cached property of the pointer
  if (Result = nil) or
     not (Result is TFpSymbolDwarfFreePascalTypePointer)
  then
    exit;

  ti := TFpSymbolDwarfFreePascalTypePointer(Result).NestedTypeInfo;
  // only if it is NOT a declaration
  if (ti <> nil) and (ti is TFpSymbolDwarfTypeStructure) then
    TFpSymbolDwarfFreePascalTypePointer(Result).IsInternalPointer := True;
end;

{ TFpSymbolDwarfFreePascalTypePointer }

function TFpSymbolDwarfFreePascalTypePointer.GetIsInternalPointer: Boolean;
begin
  Result := FIsInternalPointer or IsInternalDynArrayPointer;
end;

function TFpSymbolDwarfFreePascalTypePointer.IsInternalDynArrayPointer: Boolean;
var
  ti: TFpSymbol;
begin
  Result := False;
  ti := NestedTypeInfo;  // Same as TypeInfo, but does not try to be forwarded
  Result := (ti <> nil) and (ti is TFpSymbolDwarfTypeArray);
  if Result then
    Result := (sfDynArray in ti.Flags);
end;

procedure TFpSymbolDwarfFreePascalTypePointer.TypeInfoNeeded;
var
  p: TFpSymbol;
begin
  p := NestedTypeInfo;
  if IsInternalPointer and (p <> nil) then
    p := p.TypeInfo;
  SetTypeInfo(p);
end;

procedure TFpSymbolDwarfFreePascalTypePointer.KindNeeded;
var
  k: TDbgSymbolKind;
begin
  if IsInternalPointer then begin
      k := NestedTypeInfo.Kind;
      if k = skObject then   // TODO
        SetKind(skClass)
      else
        SetKind(k);
  end
  else
    inherited;
end;

procedure TFpSymbolDwarfFreePascalTypePointer.ForwardToSymbolNeeded;
begin
  if IsInternalPointer then
    SetForwardToSymbol(NestedTypeInfo) // Same as TypeInfo, but does not try to be forwarded
  else
    SetForwardToSymbol(nil); // inherited ForwardToSymbolNeeded;
end;

function TFpSymbolDwarfFreePascalTypePointer.GetDataAddressNext(
  AValueObj: TFpValueDwarf; var AnAddress: TFpDbgMemLocation;
  ATargetType: TFpSymbolDwarfType; ATargetCacheIndex: Integer): Boolean;
var
  t: TFpDbgMemLocation;
begin
  if not IsInternalPointer then exit(True);

  t := AValueObj.DataAddressCache[ATargetCacheIndex];
  if IsInitializedLoc(t) then begin
    AnAddress := t;
  end
  else begin
    Result := AValueObj.MemManager <> nil;
    if not Result then
      exit;
    AnAddress := AValueObj.MemManager.ReadAddress(AnAddress, CompilationUnit.AddressSize);
    AValueObj.DataAddressCache[ATargetCacheIndex] := AnAddress;
  end;
  Result := IsValidLoc(AnAddress);

  if Result then
    Result := inherited GetDataAddressNext(AValueObj, AnAddress, ATargetType, ATargetCacheIndex)
  else
  if IsError(AValueObj.MemManager.LastError) then
    SetLastError(AValueObj.MemManager.LastError);
  // Todo: other error
end;

function TFpSymbolDwarfFreePascalTypePointer.GetTypedValueObject(
  ATypeCast: Boolean): TFpValueDwarf;
begin
  if IsInternalPointer then
    Result := NestedTypeInfo.GetTypedValueObject(ATypeCast)
  else
    Result := inherited GetTypedValueObject(ATypeCast);
end;

function TFpSymbolDwarfFreePascalTypePointer.DataSize: Integer;
begin
  if Kind = skClass then
    Result := NestedTypeInfo.Size
  else
    Result := inherited DataSize;
end;

{ TFpValueDwarfV2FreePascalShortString }

function TFpValueDwarfV2FreePascalShortString.IsValidTypeCast: Boolean;
begin
  // currently only allow this / used by array access
  Result := TypeCastSourceValue is TFpValueConstAddress;
end;

function TFpValueDwarfV2FreePascalShortString.GetInternMemberByName(
  AIndex: String): TFpValue;
var
  tmp: TFpSymbol;
begin
  if HasTypeCastInfo then begin
    Result := nil;
    tmp := TypeCastTargetType.NestedSymbolByName[AIndex];
    if (tmp <> nil) then begin
      assert((tmp is TFpSymbolDwarfData), 'TDbgDwarfStructTypeCastSymbolValue.GetMemberByName'+DbgSName(tmp));
      Result := tmp.Value;

      TFpValueDwarf(Result).StructureValue := Self;
      if (TFpValueDwarf(Result).Context = nil) then
        TFpValueDwarf(Result).Context := Context;
    end;
  end
  else
    Result := MemberByName[AIndex];
end;

procedure TFpValueDwarfV2FreePascalShortString.Reset;
begin
  inherited Reset;
  FValueDone := False;
end;

function TFpValueDwarfV2FreePascalShortString.GetFieldFlags: TFpValueFieldFlags;
begin
  Result := inherited GetFieldFlags;
  Result := Result + [svfString];
end;

function TFpValueDwarfV2FreePascalShortString.GetAsString: AnsiString;
var
  len: QWord;
  LenSym, StSym: TFpValueDwarf;
begin
  if FValueDone then
    exit(FValue);

  LenSym := TFpValueDwarf(GetInternMemberByName('length'));
  assert(LenSym is TFpValueDwarf, 'LenSym is TFpValueDwarf');
  len := LenSym.AsCardinal;

  if (TypeInfo.Size < 0) or (len > TypeInfo.Size) then begin
    FLastError := CreateError(fpErrAnyError);
    exit('');
  end;

  StSym := TFpValueDwarf(GetInternMemberByName('st'));
  assert(StSym is TFpValueDwarf, 'StSym is TFpValueDwarf');



  SetLength(Result, len);
  if len > 0 then
    if not MemManager.ReadMemory(StSym.DataAddress, len, @Result[1]) then begin
      Result := ''; // TODO: error
      FLastError := MemManager.LastError;
      exit;
    end;

  FValue := Result;
  FValueDone := True;
end;

function TFpValueDwarfV2FreePascalShortString.GetAsWideString: WideString;
begin
  Result := GetAsString;
end;

{ TFpSymbolDwarfFreePascalSymbolTypeArray }

function TFpSymbolDwarfFreePascalSymbolTypeArray.GetTypedValueObject(
  ATypeCast: Boolean): TFpValueDwarf;
begin
  Result := TFpValueDwarfFreePascalArray.Create(Self);
end;

{ TFpValueDwarfFreePascalArray }

function TFpValueDwarfFreePascalArray.GetMemberCount: Integer;
var
  t, t2: TFpSymbol;
  Info: TDwarfInformationEntry;
  n: AnsiString;
  UpperBoundSym: TFpSymbolDwarf;
  val: TFpValue;
  l, h: Int64;
  Addr: TFpDbgMemLocation;
begin
  Result := 0;
  t := TypeInfo;
  if (t.Kind <> skArray) or (t.NestedSymbolCount < 1) then // IndexTypeCount;
    exit(inherited GetMemberCount);

  t2 := t.NestedSymbol[0]; // IndexType[0];
  if not (t2 is TFpSymbolDwarfTypeSubRange) then
    exit(inherited GetMemberCount);


  TFpSymbolDwarfTypeSubRange(t2).GetValueBounds(Self, l, h);
  if (l <> 0) or
     (TFpSymbolDwarfTypeSubRange(t2).LowBoundState <> rfConst) or
     (TFpSymbolDwarfTypeSubRange(t2).HighBoundState <> rfNotFound) or
     (TFpSymbolDwarfTypeSubRange(t2).CountState <> rfNotFound)
  then
    exit(inherited GetMemberCount);

  // Check for open array param
  if (t is TFpSymbolDwarfTypeArray) and
     (DbgSymbol is TFpSymbolDwarfDataParameter) // open array exists only as param
  then begin
    Info := TFpSymbolDwarfDataParameter(DbgSymbol).InformationEntry.Clone;
    Info.GoNext;
    if Info.HasValidScope and
       Info.HasAttrib(DW_AT_location) and  // the high param must have a location / cannot be a constant
       Info.ReadName(n)
    then begin
      if (n <> '') and (n[1] = '$') then // dwarf3 // TODO: make required in dwarf3
        delete(n, 1, 1);
      if (copy(n,1,4) = 'high') and (UpperCase(copy(n, 5, length(n))) = UpperCase(DbgSymbol.Name)) then begin
        UpperBoundSym := TFpSymbolDwarf.CreateSubClass('', Info);
        if UpperBoundSym <> nil then begin
          val := UpperBoundSym.Value;
          TFpValueDwarf(val).Context := Context;
          //l := t2.OrdLowBound;
          h := Val.AsInteger;
          if h > l then begin
          {$PUSH}{$Q-}
            if QWord(h - l) > 5000 then
              h := l + 5000;
          {$POP}
          Result := h - l + 1;
          end
          else
            Result := 0;
          Info.ReleaseReference;
          UpperBoundSym.ReleaseReference;
          exit;
        end;
      end;
    end;
    Info.ReleaseReference;
  end;

  // dynamic array
  if (sfDynArray in t.Flags) and (AsCardinal <> 0) and
    GetDwarfDataAddress(Addr, TFpSymbolDwarfType(Owner))
  then begin
    if not (IsReadableMem(Addr) and (LocToAddr(Addr) > AddressSize)) then
      exit(0); // dyn array, but bad data
    Addr.Address := Addr.Address - AddressSize;
    //debugln(['TFpValueDwarfArray.GetMemberCount  XXXXXXXXXXXXXXX dwarf 2 read len']);
    if MemManager.ReadSignedInt(Addr, AddressSize, h) then begin
      Result := Integer(h)+1;
      exit;
    end
    else
      FLastError := MemManager.LastError;
    Result := 0;
    exit;
  end;

  // Should not be here. There is no knowledeg how many members there are
  Result := inherited GetMemberCount;
end;

{ TFpSymbolDwarfV3FreePascalSymbolTypeArray }

function TFpSymbolDwarfV3FreePascalSymbolTypeArray.GetInternalStringType: TArrayOrStringType;
var
  Info: TDwarfInformationEntry;
  t: Cardinal;
  t2: TFpSymbol;
begin
  Result := FArrayOrStringType;
  if Result <> iasUnknown then
    exit;

  FArrayOrStringType := iasArray;
  Result := FArrayOrStringType;

  t2 := TypeInfo;
  if (t2 = nil) or (t2.Kind <> skChar) then
    exit;

  // TODO: check lowbound = 1 (const)

  Info := InformationEntry.FirstChild;
  if Info = nil then
    exit;

  while Info.HasValidScope do begin
    t := Info.AbbrevTag;
    if (t = DW_TAG_enumeration_type) then
      break;
    if (t = DW_TAG_subrange_type) then begin
      if Info.HasAttrib(DW_AT_byte_stride) or Info.HasAttrib(DW_AT_type) then
        break;

      // This is a string
      // TODO: check the location parser, if it is a reference
      //FIsShortString := iasShortString;
      if (t2.Size = 2) then
        FArrayOrStringType := iasUnicodeString
      else
        FArrayOrStringType := iasAnsiString;
      Result := FArrayOrStringType;
      break;
    end;
    Info.GoNext;
  end;

  Info.ReleaseReference;
end;

function TFpSymbolDwarfV3FreePascalSymbolTypeArray.GetTypedValueObject(
  ATypeCast: Boolean): TFpValueDwarf;
begin
  if GetInternalStringType in [{iasShortString,} iasAnsiString, iasUnicodeString] then
    Result := TFpValueDwarfV3FreePascalString.Create(Self)
  else
    Result := inherited GetTypedValueObject(ATypeCast);
end;

procedure TFpSymbolDwarfV3FreePascalSymbolTypeArray.KindNeeded;
begin
  case GetInternalStringType of
    iasShortString:
      SetKind(skString);
    iasAnsiString:
      SetKind(skString); // TODO
    iasUnicodeString:
      SetKind(skWideString);
    else
      inherited KindNeeded;
  end;
end;

{ TFpValueDwarfV3FreePascalString }

function TFpValueDwarfV3FreePascalString.IsValidTypeCast: Boolean;
var
  f: TFpValueFieldFlags;
begin
  Result := HasTypeCastInfo;
  If not Result then
    exit;

  assert(TypeCastTargetType.Kind in [skString, skWideString], 'TFpValueDwarfArray.IsValidTypeCast: TypeCastTargetType.Kind = skArray');

  f := TypeCastSourceValue.FieldFlags;
  if (f * [svfAddress, svfSize, svfSizeOfPointer] = [svfAddress]) or
     (svfOrdinal in f)
  then
    exit;

  //if sfDynArray in TypeCastTargetType.Flags then begin
  //  // dyn array
  //  if (svfOrdinal in f)then
  //    exit;
  //  if (f * [svfAddress, svfSize] = [svfAddress, svfSize]) and
  //     (TypeCastSourceValue.Size = FOwner.CompilationUnit.AddressSize)
  //  then
  //    exit;
  //  if (f * [svfAddress, svfSizeOfPointer] = [svfAddress, svfSizeOfPointer]) then
  //    exit;
  //end
  //else begin
  //  // stat array
  //  if (f * [svfAddress, svfSize] = [svfAddress, svfSize]) and
  //     (TypeCastSourceValue.Size = TypeCastTargetType.Size)
  //  then
  //    exit;
  //end;
  Result := False;
end;

procedure TFpValueDwarfV3FreePascalString.Reset;
begin
  inherited Reset;
  FValueDone := False;
end;

function TFpValueDwarfV3FreePascalString.GetFieldFlags: TFpValueFieldFlags;
begin
  Result := inherited GetFieldFlags;
  Result := Result + [svfString];
end;

function TFpValueDwarfV3FreePascalString.GetAsString: AnsiString;
var
  t, t2: TFpSymbol;
  LowBound, HighBound, i: Int64;
  Addr, Addr2: TFpDbgMemLocation;
  WResult: UnicodeString;
  AttrData: TDwarfAttribData;
begin
  if FValueDone then
    exit(FValue);

  // TODO: error handling
  FValue := '';
  Result := '';
  FValueDone := True;

  // get length
  t := TypeInfo;
  if t.NestedSymbolCount < 1 then // subrange type
    exit;

  t2 := t.NestedSymbol[0]; // subrange type
  if not( (t2 is TFpSymbolDwarfType) and TFpSymbolDwarfType(t2).GetValueBounds(self, LowBound, HighBound) )
  then
    exit;

  GetDwarfDataAddress(Addr, Owner);
  if (not IsValidLoc(Addr)) and (svfOrdinal in TypeCastSourceValue.FieldFlags) then
    Addr := TargetLoc(TypeCastSourceValue.AsCardinal);
  if not IsReadableLoc(Addr) then
    exit;

  assert((Owner <> nil) and (Owner.CompilationUnit <> nil) and (Owner.CompilationUnit.DwarfSymbolClassMap is TFpDwarfFreePascalSymbolClassMapDwarf3), 'TFpValueDwarfV3FreePascalString.GetAsString: (Owner <> nil) and (Owner.CompilationUnit <> nil) and (Owner.CompilationUnit.DwarfSymbolClassMap is TFpDwarfFreePascalSymbolClassMapDwarf3)');
  if (TFpDwarfFreePascalSymbolClassMapDwarf3(Owner.CompilationUnit.DwarfSymbolClassMap).FCompilerVersion > 0) and
     (TFpDwarfFreePascalSymbolClassMapDwarf3(Owner.CompilationUnit.DwarfSymbolClassMap).FCompilerVersion < $030100)
  then begin
    if t.Kind = skWideString then begin
      if (t2 is TFpSymbolDwarfTypeSubRange) and (LowBound = 1) then begin
        if (TFpSymbolDwarfTypeSubRange(t2).InformationEntry.GetAttribData(DW_AT_upper_bound, AttrData)) and
           (TFpSymbolDwarfTypeSubRange(t2).InformationEntry.AttribForm[AttrData.Idx] = DW_FORM_block1) and
           (IsReadableMem(Addr) and (LocToAddr(Addr) > AddressSize))
        then begin
          // fpc issue 0035359
          // read data and check for DW_OP_shr ?
          Addr2 := Addr;
          Addr2.Address := Addr2.Address - AddressSize;
          if MemManager.ReadSignedInt(Addr2, AddressSize, i) then begin
            if (i shr 1) = HighBound then
              HighBound := i;
          end
        end;
      end;
    end;
  end;

  if HighBound < LowBound then
    exit; // empty string

  // TODO: XXXXX Dynamic max limit
  {$PUSH}{$Q-}
  if QWord(HighBound - LowBound) > 5000 then
    HighBound := LowBound + 5000;
  {$POP}

  if t.Kind = skWideString then begin
    SetLength(WResult, HighBound-LowBound+1);

    if not MemManager.ReadMemory(Addr, (HighBound-LowBound+1)*2, @WResult[1]) then begin
      WResult := '';
      FLastError := MemManager.LastError;
    end;
    Result := WResult;
  end else begin
    SetLength(Result, HighBound-LowBound+1);

    if not MemManager.ReadMemory(Addr, HighBound-LowBound+1, @Result[1]) then begin
      Result := '';
      FLastError := MemManager.LastError;
    end;
  end;

  FValue := Result;

end;

function TFpValueDwarfV3FreePascalString.GetAsWideString: WideString;
begin
  // todo: widestring, but currently that is encoded as PWideChar
  Result := GetAsString;
end;

initialization
  DwarfSymbolClassMapList.AddMap(TFpDwarfFreePascalSymbolClassMapDwarf2);
  DwarfSymbolClassMapList.AddMap(TFpDwarfFreePascalSymbolClassMapDwarf3);

end.