diff --git a/components/fpdebug/fpdbgdwarf.pas b/components/fpdebug/fpdbgdwarf.pas index ae93f4d0fc..ff1d756865 100644 --- a/components/fpdebug/fpdbgdwarf.pas +++ b/components/fpdebug/fpdbgdwarf.pas @@ -510,13 +510,21 @@ type private FValue: String; FValueDone: Boolean; - function GetStringLen: Int64; + FLenSize: TFpDbgValueSize; + FHasLenSize, FLenSizeDone: Boolean; protected + function GetLenSize(out ASize: TFpDbgValueSize): boolean; + function GetStringLen: Int64; + function GetFieldFlags: TFpValueFieldFlags; override; function GetAsString: AnsiString; override; + function GetAsWideString: WideString; override; function GetSubString(AStartIndex, ALen: Int64; out ASubStr: AnsiString; AIgnoreBounds: Boolean = False): Boolean; override; + function GetSubWideString(AStartIndex, ALen: Int64; out ASubStr: WideString; + AIgnoreBounds: Boolean = False): Boolean; override; public + procedure Reset; override; end; { TFpValueDwarfSubroutine } @@ -1057,6 +1065,8 @@ DECL = DW_AT_decl_column, DW_AT_decl_file, DW_AT_decl_line protected //function DoGetNestedTypeInfo: TFpSymbolDwarfType; override; procedure KindNeeded; override; + function DoReadSize(const AValueObj: TFpValue; out ASize: TFpDbgValueSize): Boolean; override; + function DoReadLenSize(const AValueObj: TFpValue; out ASize: TFpDbgValueSize): Boolean; function DoReadLengthLocation(const AValueObj: TFpValueDwarf; out ALocation: TFpDbgMemLocation): Boolean; public function GetTypedValueObject({%H-}ATypeCast: Boolean; AnOuterType: TFpSymbolDwarfType = nil): TFpValueDwarf; override; @@ -2089,7 +2099,9 @@ end; function TFpValueDwarf.IsValidTypeCast: Boolean; begin - Result := False; + // At least for array GetMember this should always be true. + Result := TypeCastSourceValue is TFpValueConstAddress; + //Result := False; end; function TFpValueDwarf.GetKind: TDbgSymbolKind; @@ -4052,6 +4064,34 @@ end; { TFpValueDwarfString } +function TFpValueDwarfString.GetLenSize(out ASize: TFpDbgValueSize): boolean; +var + t: TFpSymbolDwarfType; +begin + ASize := FLenSize; + Result := FHasLenSize; + if FLenSizeDone then + exit; + + FLenSize := ZeroSize; + FHasLenSize := False; + FLenSizeDone := True; + + + t := TypeInfo; + if t <> nil then + t := TFpSymbolDwarfType(t.InternalTypeInfo); + if (t = nil) or not(t is TFpSymbolDwarfTypeString) then + exit; + + FHasLenSize := TFpSymbolDwarfTypeString(t).DoReadLenSize(Self, FLenSize); + if not FHasLenSize then + FLenSize := SizeVal(0); + + ASize := FLenSize; + Result := FHasLenSize; +end; + function TFpValueDwarfString.GetStringLen: Int64; var t: TFpSymbolDwarfType; @@ -4062,10 +4102,12 @@ begin Result := -1; t := TypeInfo; + if t <> nil then + t := TFpSymbolDwarfType(t.InternalTypeInfo); if (t = nil) or not(t is TFpSymbolDwarfTypeString) then exit; - HasSize := t.DoReadSize(Self, ASize); + HasSize := GetLenSize(ASize); if TFpSymbolDwarfTypeString(t).DoReadLengthLocation(Self, ALenLoc) then begin if not HasSize then @@ -4088,12 +4130,16 @@ end; function TFpValueDwarfString.GetFieldFlags: TFpValueFieldFlags; begin Result := inherited GetFieldFlags; - Result := Result + [svfString]; + if Kind = skWideString then + Result := Result + [svfWideString] + else + Result := Result + [svfString]; end; function TFpValueDwarfString.GetAsString: AnsiString; var ALen: Int64; + WResult: WideString; begin if FValueDone then exit(FValue); @@ -4111,19 +4157,38 @@ begin then ALen := MemManager.MemLimits.MaxStringLen; - SetLength(Result, ALen); - if not (Context.ReadMemory(DataAddress, SizeVal(ALen), @Result[1])) - then begin - SetLastError(Context.LastMemError); - Result := ''; + if Kind = skWideString then begin + SetLength(WResult, ALen); + if not (Context.ReadMemory(DataAddress, SizeVal(ALen*2), @WResult[1])) + then begin + SetLastError(Context.LastMemError); + Result := ''; + end + else + Result := WResult; + end + else begin + SetLength(Result, ALen); + if not (Context.ReadMemory(DataAddress, SizeVal(ALen), @Result[1])) + then begin + SetLastError(Context.LastMemError); + Result := ''; + end; end; + FValue := Result; end; +function TFpValueDwarfString.GetAsWideString: WideString; +begin + Result := GetAsString; +end; + function TFpValueDwarfString.GetSubString(AStartIndex, ALen: Int64; out ASubStr: AnsiString; AIgnoreBounds: Boolean): Boolean; var AFullLen: Int64; + WResult: WideString; begin // TODO: if FValueDone, and covers selected range, then use FValue; ASubStr := ''; @@ -4157,15 +4222,44 @@ begin then ALen := MemManager.MemLimits.MaxStringLen; - SetLength(ASubStr, ALen); - if not (Context.ReadMemory(DataAddress + AStartIndex, SizeVal(ALen), @ASubStr[1])) - then begin - SetLastError(Context.LastMemError); - ASubStr := ''; - exit; + if Kind = skWideString then begin + SetLength(WResult, ALen); + if not (Context.ReadMemory(DataAddress + AStartIndex*2, SizeVal(ALen*2), @WResult[1])) + then begin + SetLastError(Context.LastMemError); + WResult := ''; + exit; + end + else + ASubStr := WResult; + end + else begin + SetLength(ASubStr, ALen); + if not (Context.ReadMemory(DataAddress + AStartIndex, SizeVal(ALen), @ASubStr[1])) + then begin + SetLastError(Context.LastMemError); + ASubStr := ''; + exit; + end; end; end; +function TFpValueDwarfString.GetSubWideString(AStartIndex, ALen: Int64; out ASubStr: WideString; + AIgnoreBounds: Boolean): Boolean; +var + AnsiSubStr: AnsiString; +begin + Result := GetSubString(AStartIndex, ALen, AnsiSubStr, AIgnoreBounds); + ASubStr := AnsiSubStr; +end; + +procedure TFpValueDwarfString.Reset; +begin + FValueDone := False; + FLenSizeDone := False; + inherited Reset; +end; + { TDbgDwarfIdentifier } function TFpSymbolDwarf.GetNestedTypeInfo: TFpSymbolDwarfType; @@ -6600,8 +6694,31 @@ end; { TFpSymbolDwarfTypeString } procedure TFpSymbolDwarfTypeString.KindNeeded; +var + t: TFpSymbolDwarfType; + CharSize: TFpDbgValueSize; begin - SetKind(skString); + t := NestedTypeInfo; + if (t <> nil) and (t.Kind = skChar) and t.ReadSize(nil, CharSize) then begin + if CharSize.Size = 2 then + SetKind(skWideString) + else + SetKind(skString); + end + else + SetKind(skString); +end; + +function TFpSymbolDwarfTypeString.DoReadSize(const AValueObj: TFpValue; out ASize: TFpDbgValueSize + ): Boolean; +begin + Result := False; +end; + +function TFpSymbolDwarfTypeString.DoReadLenSize(const AValueObj: TFpValue; out + ASize: TFpDbgValueSize): Boolean; +begin + Result := inherited DoReadSize(AValueObj, ASize); end; function TFpSymbolDwarfTypeString.DoReadLengthLocation( @@ -6612,8 +6729,8 @@ var begin Result := False; if InformationEntry.GetAttribData(DW_AT_string_length, AttrData) then begin - ALocation := AValueObj.Address; - InitLocParserData.ObjectDataAddress := AValueObj.Address; + ALocation := AValueObj.OrdOrAddress; + InitLocParserData.ObjectDataAddress := ALocation; InitLocParserData.ObjectDataAddrPush := False; Result := LocationFromAttrData(AttrData, AValueObj, ALocation, @InitLocParserData); end; diff --git a/components/fpdebug/fpdbgdwarffreepascal.pas b/components/fpdebug/fpdbgdwarffreepascal.pas index de3ff3c2dd..2cf16b4411 100644 --- a/components/fpdebug/fpdbgdwarffreepascal.pas +++ b/components/fpdebug/fpdbgdwarffreepascal.pas @@ -237,6 +237,34 @@ type (* *** Array vs AnsiString *** *) + { TFpSymbolDwarfFreePascalTypeString } + + TFpSymbolDwarfFreePascalTypeString = class(TFpSymbolDwarfTypeString) + protected + //procedure KindNeeded; override; // Could return diff for ansi / short, but will be done in TFpValue // Short has DW_AT_byte_size for size of length == 1 *) + function DoReadSize(const AValueObj: TFpValue; out ASize: TFpDbgValueSize): Boolean; override; + public + function GetTypedValueObject({%H-}ATypeCast: Boolean; AnOuterType: TFpSymbolDwarfType = nil): TFpValueDwarf; override; + end; + + { TFpValueDwarfFreePascalString } + + TFpValueDwarfFreePascalString = class(TFpValueDwarfString) // DW_TAG_String + protected + function IsValidTypeCast: Boolean; override; + function GetFieldFlags: TFpValueFieldFlags; override; + function GetKind: TDbgSymbolKind; override; + //function GetAsString: AnsiString; override; + //function GetAsWideString: WideString; override; + function GetMemberCount: Integer; override; + procedure SetAsCardinal(AValue: QWord); override; + function GetAsCardinal: QWord; override; + //function GetSubString(AStartIndex, ALen: Int64; out ASubStr: AnsiString; + // AIgnoreBounds: Boolean = False): Boolean; override; + //function GetSubWideString(AStartIndex, ALen: Int64; out ASubStr: WideString; + // AIgnoreBounds: Boolean = False): Boolean; override; + end; + { TFpSymbolDwarfV3FreePascalSymbolTypeArray } TFpSymbolDwarfV3FreePascalSymbolTypeArray = class(TFpSymbolDwarfFreePascalSymbolTypeArray) @@ -430,6 +458,7 @@ begin DW_TAG_structure_type, DW_TAG_class_type: Result := TFpSymbolDwarfFreePascalTypeStructure; DW_TAG_array_type: Result := TFpSymbolDwarfFreePascalSymbolTypeArray; + DW_TAG_string_type: Result := TFpSymbolDwarfFreePascalTypeString; DW_TAG_subprogram: Result := TFpSymbolDwarfFreePascalDataProc; DW_TAG_formal_parameter: Result := TFpSymbolDwarfFreePascalDataParameter; else Result := inherited GetDwarfSymbolClass(ATag); @@ -1484,6 +1513,91 @@ begin Result := Context.ReadSignedInt(Addr, SizeVal(AddressSize), ARefCount); end; +{ TFpSymbolDwarfFreePascalTypeString } + +function TFpSymbolDwarfFreePascalTypeString.DoReadSize(const AValueObj: TFpValue; out + ASize: TFpDbgValueSize): Boolean; +begin + Result := DoReadLenSize(nil, ASize) and (ASize >= 4); // not shortstring + + ASize := ZeroSize; + ASize.Size := CompilationUnit.AddressSize; +end; + +function TFpSymbolDwarfFreePascalTypeString.GetTypedValueObject(ATypeCast: Boolean; + AnOuterType: TFpSymbolDwarfType): TFpValueDwarf; +begin + if AnOuterType = nil then + AnOuterType := Self; + Result := TFpValueDwarfFreePascalString.Create(AnOuterType); +end; + +{ TFpValueDwarfFreePascalString } + +function TFpValueDwarfFreePascalString.IsValidTypeCast: Boolean; +var + f: TFpValueFieldFlags; +begin + Result := inherited IsValidTypeCast; + if Result then + exit; + Result := HasTypeCastInfo; + If not Result then + exit; + + f := TypeCastSourceValue.FieldFlags; + if (f * [svfAddress, svfSize, svfSizeOfPointer] = [svfAddress]) or + (svfOrdinal in f) + then + exit; +end; + +function TFpValueDwarfFreePascalString.GetFieldFlags: TFpValueFieldFlags; +begin + Result := inherited GetFieldFlags; + + if Kind in [skWideString, skAnsiString] then + Result := Result + [svfDataAddress, svfSizeOfPointer, svfOrdinal]; +end; + +function TFpValueDwarfFreePascalString.GetKind: TDbgSymbolKind; +var + s: TFpDbgValueSize; +begin + Result := inherited GetKind; + if (Result = skString) and GetLenSize(s) and (s >= 4) then + Result := skAnsiString; +end; + +function TFpValueDwarfFreePascalString.GetMemberCount: Integer; +var + ALen: Int64; +begin + if GetStringLen(ALen) and (ALen < MaxInt) then + Result := ALen + else + Result := 0; +end; + +procedure TFpValueDwarfFreePascalString.SetAsCardinal(AValue: QWord); +begin + if not Context.WriteUnsignedInt(Address, SizeVal(AddressSize), AValue) then begin + SetLastError(Context.LastMemError); + end; + Reset; +end; + +function TFpValueDwarfFreePascalString.GetAsCardinal: QWord; +var + d: TFpDbgMemLocation; +begin + d := DataAddress; + if IsTargetAddr(d) then + Result := DataAddress.Address + else + Result := inherited GetAsCardinal; +end; + { TFpSymbolDwarfV3FreePascalSymbolTypeArray } function TFpSymbolDwarfV3FreePascalSymbolTypeArray.GetInternalStringType: TArrayOrStringType; diff --git a/components/lazdebuggers/lazdebuggerfp/fpdebugdebuggerworkthreads.pas b/components/lazdebuggers/lazdebuggerfp/fpdebugdebuggerworkthreads.pas index 001e2e9f30..e6ddbfc468 100644 --- a/components/lazdebuggers/lazdebuggerfp/fpdebugdebuggerworkthreads.pas +++ b/components/lazdebuggers/lazdebuggerfp/fpdebugdebuggerworkthreads.pas @@ -980,7 +980,8 @@ begin end else if (TempSymbol.Kind <> rk) and - not ( (TempSymbol.Kind in [skInteger, skCardinal]) and (rk in [skInteger, skCardinal]) ) + not ( (TempSymbol.Kind in [skInteger, skCardinal]) and (rk in [skInteger, skCardinal]) ) and + not ( (TempSymbol.Kind in [skString, skAnsiString]) and (rk in [skString, skAnsiString]) ) then begin DebugLn(FPDBG_FUNCCALL or DBG_WARNINGS, 'Error kind mismatch for arg %d : %s <> %s', [FoundIdx, dbgs(TempSymbol.Kind), dbgs(rk)]); AnError := CreateError(fpErrAnyError, ['wrong type for parameter']);