1 {
2 ---------------------------------------------------------------------------
3 fpdbgdwarf.pas - Native Freepascal debugger - Dwarf symbol processing
4 ---------------------------------------------------------------------------
5
6 This unit contains helper classes for handling and evaluating of debuggee data
7 described by DWARF debug symbols
8
9 ---------------------------------------------------------------------------
10
11 @created(Mon Aug 1st WET 2006)
12 @lastmod($Date: 2019-07-22 12:41:53 +0200 (Mo, 22 Jul 2019) $)
13 @author(Marc Weustink <marc@@dommelstein.nl>)
14 @author(Martin Friebe)
15
16 ***************************************************************************
17 * *
18 * This source is free software; you can redistribute it and/or modify *
19 * it under the terms of the GNU General Public License as published by *
20 * the Free Software Foundation; either version 2 of the License, or *
21 * (at your option) any later version. *
22 * *
23 * This code is distributed in the hope that it will be useful, but *
24 * WITHOUT ANY WARRANTY; without even the implied warranty of *
25 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
26 * General Public License for more details. *
27 * *
28 * A copy of the GNU General Public License is available on the World *
29 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
30 * obtain it by writing to the Free Software Foundation, *
31 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
32 * *
33 ***************************************************************************
34 }
35 unit FpDbgDwarf;
36
37 {$mode objfpc}{$H+}
38 {off $INLINE OFF}
39
40 (* Notes:
41
42 * FpDbgDwarfValues and Context
43 The Values do not add a reference to the Context. Yet they require the Context.
44 It is the users responsibility to keep the context, as long as any value exists.
45
46 *)
47
48 interface
49
50 uses
51 Classes, SysUtils, types, math, FpDbgInfo, FpDbgDwarfDataClasses, FpdMemoryTools, FpErrorMessages,
52 FpDbgUtil, FpDbgDwarfConst, DbgIntfBaseTypes, LazUTF8, LazLoggerBase, LazClasses;
53
54 type
55 TFpDwarfInfo = FpDbgDwarfDataClasses.TFpDwarfInfo;
56
57 { TFpDwarfDefaultSymbolClassMap }
58
59 TFpDwarfDefaultSymbolClassMap = class(TFpDwarfSymbolClassMap)
60 public
HandleCompUnitnull61 class function HandleCompUnit(ACU: TDwarfCompilationUnit): Boolean; override;
GetDwarfSymbolClassnull62 class function GetDwarfSymbolClass(ATag: Cardinal): TDbgDwarfSymbolBaseClass; override;
CreateContextnull63 class function CreateContext(AThreadId, AStackFrame: Integer; AnAddress:
64 TDbgPtr; ASymbol: TFpDbgSymbol; ADwarf: TFpDwarfInfo): TFpDbgInfoContext; override;
CreateProcSymbolnull65 class function CreateProcSymbol(ACompilationUnit: TDwarfCompilationUnit;
66 AInfo: PDwarfAddressInfo; AAddress: TDbgPtr): TDbgDwarfSymbolBase; override;
67 end;
68
69 { TFpDwarfInfoAddressContext }
70
71 TFpDwarfInfoAddressContext = class(TFpDbgInfoContext)
72 private
73 FSymbol: TFpDbgSymbol;
74 FAddress: TDBGPtr;
75 FThreadId, FStackFrame: Integer;
76 FDwarf: TFpDwarfInfo;
77 FlastResult: TFpDbgValue;
78 protected
GetSymbolAtAddressnull79 function GetSymbolAtAddress: TFpDbgSymbol; override;
GetProcedureAtAddressnull80 function GetProcedureAtAddress: TFpDbgValue; override;
GetAddressnull81 function GetAddress: TDbgPtr; override;
GetThreadIdnull82 function GetThreadId: Integer; override;
GetStackFramenull83 function GetStackFrame: Integer; override;
GetSizeOfAddressnull84 function GetSizeOfAddress: Integer; override;
GetMemManagernull85 function GetMemManager: TFpDbgMemManager; override;
86
87 property Symbol: TFpDbgSymbol read FSymbol;
88 property Dwarf: TFpDwarfInfo read FDwarf;
89 property Address: TDBGPtr read FAddress write FAddress;
90 property ThreadId: Integer read FThreadId write FThreadId;
91 property StackFrame: Integer read FStackFrame write FStackFrame;
92
93 procedure ApplyContext(AVal: TFpDbgValue); inline;
SymbolToValuenull94 function SymbolToValue(ASym: TFpDbgSymbol): TFpDbgValue; inline;
95 procedure AddRefToVal(AVal: TFpDbgValue); inline;
GetSelfParameternull96 function GetSelfParameter: TFpDbgValue; virtual;
97
FindExportedSymbolInUnitsnull98 function FindExportedSymbolInUnits(const AName: String; PNameUpper, PNameLower: PChar;
99 SkipCompUnit: TDwarfCompilationUnit; out ADbgValue: TFpDbgValue): Boolean; inline;
FindSymbolInStructurenull100 function FindSymbolInStructure(const AName: String; PNameUpper, PNameLower: PChar;
101 InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpDbgValue): Boolean; inline;
102 // FindLocalSymbol: for the subroutine itself
FindLocalSymbolnull103 function FindLocalSymbol(const AName: String; PNameUpper, PNameLower: PChar;
104 InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpDbgValue): Boolean; virtual;
105 public
106 constructor Create(AThreadId, AStackFrame: Integer; AnAddress: TDbgPtr; ASymbol: TFpDbgSymbol; ADwarf: TFpDwarfInfo);
107 destructor Destroy; override;
FindSymbolnull108 function FindSymbol(const AName: String): TFpDbgValue; override;
109 end;
110
111 TFpDwarfSymbol = class;
112 TFpDwarfSymbolType = class;
113 TFpDwarfSymbolValue = class;
114 TFpDwarfSymbolValueClass = class of TFpDwarfSymbolValue;
115 TFpDwarfSymbolTypeClass = class of TFpDwarfSymbolType;
116
117 {%region Value objects }
118
119 { TFpDwarfValueBase }
120
121 TFpDwarfValueBase = class(TFpDbgValue)
122 private
123 FContext: TFpDbgInfoContext;
124 public
125 property Context: TFpDbgInfoContext read FContext write FContext;
126 end;
127
128 { TFpDwarfValueTypeDefinition }
129
130 TFpDwarfValueTypeDefinition = class(TFpDwarfValueBase)
131 private
132 FSymbol: TFpDbgSymbol; // stType
133 protected
GetKindnull134 function GetKind: TDbgSymbolKind; override;
GetDbgSymbolnull135 function GetDbgSymbol: TFpDbgSymbol; override;
136 public
137 constructor Create(ASymbol: TFpDbgSymbol); // Only for stType
138 destructor Destroy; override;
GetTypeCastedValuenull139 function GetTypeCastedValue(ADataVal: TFpDbgValue): TFpDbgValue; override;
140 end;
141
142 { TFpDwarfValue }
143
144 TFpDwarfValue = class(TFpDwarfValueBase)
145 private
146 FOwner: TFpDwarfSymbolType; // the creator, usually the type
147 FValueSymbol: TFpDwarfSymbolValue;
148 FTypeCastTargetType: TFpDwarfSymbolType;
149 FTypeCastSourceValue: TFpDbgValue;
150
151 FDataAddressCache: array of TFpDbgMemLocation;
152 FStructureValue: TFpDwarfValue;
153 FLastMember: TFpDwarfValue;
GetDataAddressCachenull154 function GetDataAddressCache(AIndex: Integer): TFpDbgMemLocation;
155 procedure SetDataAddressCache(AIndex: Integer; AValue: TFpDbgMemLocation);
156 procedure SetStructureValue(AValue: TFpDwarfValue);
157 protected
158 FLastError: TFpError;
MemManagernull159 function MemManager: TFpDbgMemManager; inline;
160 procedure DoReferenceAdded; override;
161 procedure DoReferenceReleased; override;
162 procedure CircleBackRefActiveChanged(NewActive: Boolean); override;
163 procedure SetLastMember(ALastMember: TFpDwarfValue);
GetLastErrornull164 function GetLastError: TFpError; override;
AddressSizenull165 function AddressSize: Byte; inline;
166
167 // Address of the symbol (not followed any type deref, or location)
GetAddressnull168 function GetAddress: TFpDbgMemLocation; override;
OrdOrAddressnull169 function OrdOrAddress: TFpDbgMemLocation;
170 // Address of the data (followed type deref, location, ...)
DataAddrnull171 function DataAddr: TFpDbgMemLocation;
OrdOrDataAddrnull172 function OrdOrDataAddr: TFpDbgMemLocation;
GetDwarfDataAddressnull173 function GetDwarfDataAddress(out AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType = nil): Boolean;
GetStructureDwarfDataAddressnull174 function GetStructureDwarfDataAddress(out AnAddress: TFpDbgMemLocation;
175 ATargetType: TFpDwarfSymbolType = nil): Boolean;
HasDwarfDataAddressnull176 function HasDwarfDataAddress: Boolean; // TODO: is this just HasAddress?
177
178 procedure Reset; virtual; // keeps lastmember and structureninfo
GetFieldFlagsnull179 function GetFieldFlags: TFpDbgValueFieldFlags; override;
HasTypeCastInfonull180 function HasTypeCastInfo: Boolean;
IsValidTypeCastnull181 function IsValidTypeCast: Boolean; virtual;
GetKindnull182 function GetKind: TDbgSymbolKind; override;
GetMemberCountnull183 function GetMemberCount: Integer; override;
GetMemberByNamenull184 function GetMemberByName(AIndex: String): TFpDbgValue; override;
GetMembernull185 function GetMember(AIndex: Int64): TFpDbgValue; override;
GetDbgSymbolnull186 function GetDbgSymbol: TFpDbgSymbol; override;
GetTypeInfonull187 function GetTypeInfo: TFpDbgSymbol; override;
GetContextTypeInfonull188 function GetContextTypeInfo: TFpDbgSymbol; override;
189
190 property TypeCastTargetType: TFpDwarfSymbolType read FTypeCastTargetType;
191 property TypeCastSourceValue: TFpDbgValue read FTypeCastSourceValue;
192 public
193 constructor Create(AOwner: TFpDwarfSymbolType);
194 destructor Destroy; override;
195 procedure SetValueSymbol(AValueSymbol: TFpDwarfSymbolValue);
SetTypeCastInfonull196 function SetTypeCastInfo(AStructure: TFpDwarfSymbolType;
197 ASource: TFpDbgValue): Boolean; // Used for Typecast
198 // StructureValue: Any Value returned via GetMember points to its structure
199 property StructureValue: TFpDwarfValue read FStructureValue write SetStructureValue;
200 // DataAddressCache[0]: ValueAddress // DataAddressCache[1..n]: DataAddress
201 property DataAddressCache[AIndex: Integer]: TFpDbgMemLocation read GetDataAddressCache write SetDataAddressCache;
202 end;
203
204 TFpDwarfValueUnknown = class(TFpDwarfValue)
205 end;
206
207 { TFpDwarfValueSized }
208
209 TFpDwarfValueSized = class(TFpDwarfValue)
210 private
211 FSize: Integer;
212 protected
CanUseTypeCastAddressnull213 function CanUseTypeCastAddress: Boolean;
GetFieldFlagsnull214 function GetFieldFlags: TFpDbgValueFieldFlags; override;
GetSizenull215 function GetSize: Integer; override;
216 public
217 constructor Create(AOwner: TFpDwarfSymbolType; ASize: Integer);
218 end;
219
220 { TFpDwarfValueNumeric }
221
222 TFpDwarfValueNumeric = class(TFpDwarfValueSized)
223 protected
224 FEvaluated: set of (doneUInt, doneInt, doneAddr, doneFloat);
225 protected
226 procedure Reset; override;
GetFieldFlagsnull227 function GetFieldFlags: TFpDbgValueFieldFlags; override; // svfOrdinal
IsValidTypeCastnull228 function IsValidTypeCast: Boolean; override;
229 public
230 constructor Create(AOwner: TFpDwarfSymbolType; ASize: Integer);
231 end;
232
233 { TFpDwarfValueInteger }
234
235 TFpDwarfValueInteger = class(TFpDwarfValueNumeric)
236 private
237 FIntValue: Int64;
238 protected
GetFieldFlagsnull239 function GetFieldFlags: TFpDbgValueFieldFlags; override;
GetAsCardinalnull240 function GetAsCardinal: QWord; override;
GetAsIntegernull241 function GetAsInteger: Int64; override;
242 end;
243
244 { TFpDwarfValueCardinal }
245
246 TFpDwarfValueCardinal = class(TFpDwarfValueNumeric)
247 private
248 FValue: QWord;
249 protected
GetAsCardinalnull250 function GetAsCardinal: QWord; override;
GetFieldFlagsnull251 function GetFieldFlags: TFpDbgValueFieldFlags; override;
252 end;
253
254 { TFpDwarfValueFloat }
255
256 TFpDwarfValueFloat = class(TFpDwarfValueNumeric) // TDbgDwarfSymbolValue
257 // TODO: typecasts to int should convert
258 private
259 FValue: Extended;
260 protected
GetFieldFlagsnull261 function GetFieldFlags: TFpDbgValueFieldFlags; override;
GetAsFloatnull262 function GetAsFloat: Extended; override;
263 end;
264
265 { TFpDwarfValueBoolean }
266
267 TFpDwarfValueBoolean = class(TFpDwarfValueCardinal)
268 protected
GetFieldFlagsnull269 function GetFieldFlags: TFpDbgValueFieldFlags; override;
GetAsBoolnull270 function GetAsBool: Boolean; override;
271 end;
272
273 { TFpDwarfValueChar }
274
275 TFpDwarfValueChar = class(TFpDwarfValueCardinal)
276 protected
277 // returns single char(byte) / widechar
GetFieldFlagsnull278 function GetFieldFlags: TFpDbgValueFieldFlags; override;
GetAsStringnull279 function GetAsString: AnsiString; override;
GetAsWideStringnull280 function GetAsWideString: WideString; override;
281 end;
282
283 { TFpDwarfValuePointer }
284
285 TFpDwarfValuePointer = class(TFpDwarfValueNumeric)
286 private
287 FLastAddrMember: TFpDbgValue;
288 FPointetToAddr: TFpDbgMemLocation;
289 protected
GetAsCardinalnull290 function GetAsCardinal: QWord; override;
GetFieldFlagsnull291 function GetFieldFlags: TFpDbgValueFieldFlags; override;
GetDataAddressnull292 function GetDataAddress: TFpDbgMemLocation; override;
GetAsStringnull293 function GetAsString: AnsiString; override;
GetAsWideStringnull294 function GetAsWideString: WideString; override;
GetMembernull295 function GetMember(AIndex: Int64): TFpDbgValue; override;
296 public
297 destructor Destroy; override;
298 end;
299
300 { TFpDwarfValueEnum }
301
302 TFpDwarfValueEnum = class(TFpDwarfValueNumeric)
303 private
304 FValue: QWord;
305 FMemberIndex: Integer;
306 FMemberValueDone: Boolean;
307 procedure InitMemberIndex;
308 protected
309 procedure Reset; override;
IsValidTypeCastnull310 //function IsValidTypeCast: Boolean; override;
311 function GetFieldFlags: TFpDbgValueFieldFlags; override;
GetAsCardinalnull312 function GetAsCardinal: QWord; override;
GetAsStringnull313 function GetAsString: AnsiString; override;
314 // Has exactly 0 (if the ordinal value is out of range) or 1 member (the current value's enum)
315 function GetMemberCount: Integer; override;
316 function GetMember({%H-}AIndex: Int64): TFpDbgValue; override;
317 end;
318
319 { TFpDwarfValueEnumMember }
320
321 TFpDwarfValueEnumMember = class(TFpDwarfValue)
322 private
323 FOwnerVal: TFpDwarfSymbolValue;
324 protected
325 function GetFieldFlags: TFpDbgValueFieldFlags; override;
326 function GetAsCardinal: QWord; override;
327 function GetAsString: AnsiString; override;
328 function IsValidTypeCast: Boolean; override;
329 public
330 constructor Create(AOwner: TFpDwarfSymbolValue);
331 end;
332
333 { TFpDwarfValueConstNumber }
334
335 TFpDwarfValueConstNumber = class(TFpDbgValueConstNumber)
336 protected
337 procedure Update(AValue: QWord; ASigned: Boolean);
338 end;
339
340 { TFpDwarfValueSet }
341
342 TFpDwarfValueSet = class(TFpDwarfValueSized)
343 private
344 FMem: array of Byte;
345 FMemberCount: Integer;
346 FMemberMap: array of Integer;
347 FNumValue: TFpDwarfValueConstNumber;
348 FTypedNumValue: TFpDbgValue;
349 procedure InitMap;
350 protected
351 procedure Reset; override;
352 function GetFieldFlags: TFpDbgValueFieldFlags; override;
353 function GetMemberCount: Integer; override;
354 function GetMember(AIndex: Int64): TFpDbgValue; override;
355 function GetAsCardinal: QWord; override; // only up to qmord
356 function IsValidTypeCast: Boolean; override;
357 public
358 destructor Destroy; override;
359 end;
360
361 { TFpDwarfValueStruct }
362
363 TFpDwarfValueStruct = class(TFpDwarfValue)
364 private
365 FDataAddress: TFpDbgMemLocation;
366 FDataAddressDone: Boolean;
367 protected
368 procedure Reset; override;
369 function GetFieldFlags: TFpDbgValueFieldFlags; override;
370 function GetAsCardinal: QWord; override;
371 function GetDataAddress: TFpDbgMemLocation; override;
372 function GetDataSize: Integer; override;
373 function GetSize: Integer; override;
374 end;
375
376 { TFpDwarfValueStructTypeCast }
377
378 TFpDwarfValueStructTypeCast = class(TFpDwarfValue)
379 private
380 FMembers: TFpDbgCircularRefCntObjList;
381 FDataAddress: TFpDbgMemLocation;
382 FDataAddressDone: Boolean;
383 protected
384 procedure Reset; override;
385 function GetFieldFlags: TFpDbgValueFieldFlags; override;
386 function GetKind: TDbgSymbolKind; override;
387 function GetAsCardinal: QWord; override;
388 function GetSize: Integer; override;
389 function GetDataSize: Integer; override;
390 function GetDataAddress: TFpDbgMemLocation; override;
391 function IsValidTypeCast: Boolean; override;
392 public
393 destructor Destroy; override;
394 function GetMemberByName(AIndex: String): TFpDbgValue; override;
395 function GetMember(AIndex: Int64): TFpDbgValue; override;
396 function GetMemberCount: Integer; override;
397 end;
398
399 { TFpDwarfValueConstAddress }
400
401 TFpDwarfValueConstAddress = class(TFpDbgValueConstAddress)
402 protected
403 procedure Update(AnAddress: TFpDbgMemLocation);
404 end;
405
406 { TFpDwarfValueArray }
407
408 TFpDwarfValueArray = class(TFpDwarfValue)
409 private
410 FAddrObj: TFpDwarfValueConstAddress;
411 protected
412 function GetFieldFlags: TFpDbgValueFieldFlags; override;
413 function GetKind: TDbgSymbolKind; override;
414 function GetAsCardinal: QWord; override;
415 function GetDataAddress: TFpDbgMemLocation; override;
416 function GetMember(AIndex: Int64): TFpDbgValue; override;
417 function GetMemberEx(const AIndex: array of Int64): TFpDbgValue; override;
418 function GetMemberCount: Integer; override;
419 function GetMemberCountEx(const AIndex: array of Int64): Integer; override;
420 function GetIndexType(AIndex: Integer): TFpDbgSymbol; override;
421 function GetIndexTypeCount: Integer; override;
422 function IsValidTypeCast: Boolean; override;
423 public
424 destructor Destroy; override;
425 end;
426 {%endregion Value objects }
427
428 {%region Symbol objects }
429
430 TInitLocParserData = record
431 (* DW_AT_data_member_location: Is always pushed on stack
432 DW_AT_data_location: Is avalibale for DW_OP_push_object_address
433 *)
434 ObjectDataAddress: TFpDbgMemLocation;
435 ObjectDataAddrPush: Boolean; // always push ObjectDataAddress on stack: DW_AT_data_member_location
436 end;
437 PInitLocParserData = ^TInitLocParserData;
438
439 { TDbgDwarfIdentifier }
440
441 { TFpDwarfSymbol }
442
443 TFpDwarfSymbol = class(TDbgDwarfSymbolBase)
444 private
445 FNestedTypeInfo: TFpDwarfSymbolType;
446 FParentTypeInfo: TFpDwarfSymbol;
447 FDwarfReadFlags: set of (didtNameRead, didtTypeRead, didtArtificialRead, didtIsArtifical);
448 function GetNestedTypeInfo: TFpDwarfSymbolType;
449 protected
450 (* There will be a circular reference between parenttype and self
451 "self" will only set its reference to parenttype, if self has other references. *)
452 procedure DoReferenceAdded; override;
453 procedure DoReferenceReleased; override;
454 procedure CircleBackRefActiveChanged(ANewActive: Boolean); override;
455 procedure SetParentTypeInfo(AValue: TFpDwarfSymbol); virtual;
456
457 function DoGetNestedTypeInfo: TFpDwarfSymbolType; virtual;
458 function ReadMemberVisibility(out AMemberVisibility: TDbgSymbolMemberVisibility): Boolean;
459 function IsArtificial: Boolean; // usud by formal param and subprogram
460 procedure NameNeeded; override;
461 procedure TypeInfoNeeded; override;
462 property NestedTypeInfo: TFpDwarfSymbolType read GetNestedTypeInfo;
463
464 // OwnerTypeInfo: reverse of "NestedTypeInfo" (variable that is of this type)
465 // property OwnerTypeInfo: TDbgDwarfIdentifier read FOwnerTypeInfo; // write SetOwnerTypeInfo;
466 // ParentTypeInfo: funtion for local var / class for member
467 property ParentTypeInfo: TFpDwarfSymbol read FParentTypeInfo write SetParentTypeInfo;
468
469 function DataSize: Integer; virtual;
470 protected
471 function InitLocationParser(const {%H-}ALocationParser: TDwarfLocationExpression;
472 AnInitLocParserData: PInitLocParserData = nil): Boolean; virtual;
473 function LocationFromTag(ATag: Cardinal; AValueObj: TFpDwarfValue;
474 var AnAddress: TFpDbgMemLocation; // kept, if tag does not exist
475 AnInitLocParserData: PInitLocParserData = nil;
476 AnInformationEntry: TDwarfInformationEntry = nil;
477 ASucessOnMissingTag: Boolean = False
478 ): Boolean;
479 // GetDataAddress: data of a class, or string
480 function GetDataAddress(AValueObj: TFpDwarfValue; var AnAddress: TFpDbgMemLocation;
481 ATargetType: TFpDwarfSymbolType; ATargetCacheIndex: Integer): Boolean;
482 function GetDataAddressNext(AValueObj: TFpDwarfValue; var AnAddress: TFpDbgMemLocation;
483 ATargetType: TFpDwarfSymbolType; ATargetCacheIndex: Integer): Boolean; virtual;
484 function HasAddress: Boolean; virtual;
485
486 procedure Init; override;
487 public
488 class function CreateSubClass(AName: String; AnInformationEntry: TDwarfInformationEntry): TFpDwarfSymbol;
489 destructor Destroy; override;
490 function StartScope: TDbgPtr; // return 0, if none. 0 includes all anyway
491 end;
492
493 { TFpDwarfSymbolValue }
494
495 TFpDwarfSymbolValue = class(TFpDwarfSymbol) // var, const, member, ...
496 protected
497 FValueObject: TFpDwarfValue;
498 FMembers: TFpDbgCircularRefCntObjList;
499
500 function GetValueAddress({%H-}AValueObj: TFpDwarfValue;{%H-} out AnAddress: TFpDbgMemLocation): Boolean; virtual;
501 function GetValueDataAddress(AValueObj: TFpDwarfValue; out AnAddress: TFpDbgMemLocation;
502 ATargetType: TFpDwarfSymbolType = nil): Boolean;
503 procedure KindNeeded; override;
504 procedure MemberVisibilityNeeded; override;
505 function GetMember(AIndex: Int64): TFpDbgSymbol; override;
506 function GetMemberByName(AIndex: String): TFpDbgSymbol; override;
507 function GetMemberCount: Integer; override;
508
509 procedure Init; override;
510 public
511 destructor Destroy; override;
512 class function CreateValueSubClass(AName: String; AnInformationEntry: TDwarfInformationEntry): TFpDwarfSymbolValue;
513 end;
514
515 { TFpDwarfSymbolValueWithLocation }
516
517 TFpDwarfSymbolValueWithLocation = class(TFpDwarfSymbolValue)
518 private
519 procedure FrameBaseNeeded(ASender: TObject); // Sender = TDwarfLocationExpression
520 protected
521 function GetValueObject: TFpDbgValue; override;
522 function InitLocationParser(const ALocationParser: TDwarfLocationExpression;
523 AnInitLocParserData: PInitLocParserData): Boolean; override;
524 end;
525
526 { TFpDwarfSymbolType }
527
528 (* Types and allowed tags in dwarf 2
529
530 DW_TAG_enumeration_type, DW_TAG_subroutine_type, DW_TAG_union_type,
531 DW_TAG_ptr_to_member_type, DW_TAG_set_type, DW_TAG_subrange_type, DW_TAG_file_type,
532 DW_TAG_thrown_type
533
534 DW_TAG_base_type
535 DW_AT_encoding Y
536 DW_AT_bit_offset Y
537 DW_AT_bit_size Y
538
539 DW_TAG_base_type
540 | DW_TAG_typedef
541 | | DW_TAG_string_type
542 | | | DW_TAG_array_type
543 | | | |
544 | | | | DW_TAG_class_type
545 | | | | | DW_TAG_structure_type
546 | | | | | |
547 | | | | | | DW_TAG_enumeration_type
548 | | | | | | | DW_TAG_set_type
549 | | | | | | | | DW_TAG_enumerator
550 | | | | | | | | | DW_TAG_subrange_type
551 DW_AT_name Y Y Y Y Y Y Y Y Y Y
552 DW_AT_sibling Y Y Y Y Y Y Y Y Y Y
553 DECL Y Y Y Y Y Y Y Y Y
554 DW_AT_byte_size Y Y Y Y Y Y Y Y
555 DW_AT_abstract_origin Y Y Y Y Y Y Y Y
556 DW_AT_accessibility Y Y Y Y Y Y Y Y
557 DW_AT_declaration Y Y Y Y Y Y Y Y
558 DW_AT_start_scope Y Y Y Y Y Y Y
559 DW_AT_visibility Y Y Y Y Y Y Y Y
560 DW_AT_type Y Y Y Y
561 DW_AT_segment Y DW_TAG_string_type
562 DW_AT_string_length Y
563 DW_AT_ordering Y DW_TAG_array_type
564 DW_AT_stride_size Y
565 DW_AT_const_value Y DW_TAG_enumerator
566 DW_AT_count Y DW_TAG_subrange_type
567 DW_AT_lower_bound Y
568 DW_AT_upper_bound Y
569
570 DW_TAG_pointer_type
571 | DW_TAG_reference_type
572 | | DW_TAG_packed_type
573 | | | DW_TAG_const_type
574 | | | | DW_TAG_volatile_type
575 DW_AT_address_class Y Y
576 DW_AT_sibling Y Y Y Y Y
577 DW_AT_type Y Y Y Y Y
578
579 DECL = DW_AT_decl_column, DW_AT_decl_file, DW_AT_decl_line
580 *)
581
582 TFpDwarfSymbolType = class(TFpDwarfSymbol)
583 protected
584 procedure Init; override;
585 procedure MemberVisibilityNeeded; override;
586 procedure SizeNeeded; override;
587 function GetTypedValueObject({%H-}ATypeCast: Boolean): TFpDwarfValue; virtual; // returns refcount=1 for caller, no cached copy kept
588 public
589 class function CreateTypeSubClass(AName: String; AnInformationEntry: TDwarfInformationEntry): TFpDwarfSymbolType;
590 function TypeCastValue(AValue: TFpDbgValue): TFpDbgValue; override;
591 // TODO: flag bounds as cardinal if needed
592 function GetValueBounds({%H-}AValueObj: TFpDwarfValue; out ALowBound, AHighBound: Int64): Boolean; virtual;
593
594 (*TODO: workaround / quickfix // only partly implemented
595 When reading several elements of an array (dyn or stat), the typeinfo is always the same instance (type of array entry)
596 But once that instance has read data (like bounds / dwarf3 bounds are read from app mem), this is cached.
597 So all consecutive entries get the same info...
598 array of string
599 array of shortstring
600 array of {dyn} array
601 This works similar to "Init", but should only clear data that is not static / depends on memory reads
602
603 Bounds (and maybe all such data) should be stored on the value object)
604 *)
605 procedure ResetValueBounds; virtual;
606 end;
607
608 { TFpDwarfSymbolTypeBasic }
609
610 TFpDwarfSymbolTypeBasic = class(TFpDwarfSymbolType)
611 //function DoGetNestedTypeInfo: TFpDwarfSymbolType; // return nil
612 protected
613 procedure KindNeeded; override;
614 procedure TypeInfoNeeded; override;
615 function GetTypedValueObject({%H-}ATypeCast: Boolean): TFpDwarfValue; override;
616 function GetHasBounds: Boolean; override;
617 function GetOrdHighBound: Int64; override;
618 function GetOrdLowBound: Int64; override;
619 end;
620
621 { TFpDwarfSymbolTypeModifier }
622
623 TFpDwarfSymbolTypeModifier = class(TFpDwarfSymbolType)
624 protected
625 procedure TypeInfoNeeded; override;
626 procedure ForwardToSymbolNeeded; override;
627 function GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue; override;
628 end;
629
630 { TFpDwarfSymbolTypeRef }
631
632 TFpDwarfSymbolTypeRef = class(TFpDwarfSymbolTypeModifier)
633 protected
634 function GetFlags: TDbgSymbolFlags; override;
635 function GetDataAddressNext(AValueObj: TFpDwarfValue; var AnAddress: TFpDbgMemLocation;
636 ATargetType: TFpDwarfSymbolType; ATargetCacheIndex: Integer): Boolean; override;
637 end;
638
639 { TFpDwarfSymbolTypeDeclaration }
640
641 TFpDwarfSymbolTypeDeclaration = class(TFpDwarfSymbolTypeModifier)
642 protected
643 // fpc encodes classes as pointer, not ref (so Obj1 = obj2 compares the pointers)
644 // typedef > pointer > srtuct
645 // while a pointer to class/object: pointer > typedef > ....
646 function DoGetNestedTypeInfo: TFpDwarfSymbolType; override;
647 end;
648
649 { TFpDwarfSymbolTypeSubRange }
650 TFpDwarfSubRangeBoundReadState = (rfNotRead, rfNotFound, rfConst, rfValue);
651
652 TFpDwarfSymbolTypeSubRange = class(TFpDwarfSymbolTypeModifier)
653 // TODO not a modifier, maybe have a forwarder base class
654 private
655 FLowBoundConst: Int64;
656 FLowBoundValue: TFpDwarfSymbolValue;
657 FLowBoundState: TFpDwarfSubRangeBoundReadState;
658 FHighBoundConst: Int64;
659 FHighBoundValue: TFpDwarfSymbolValue;
660 FHighBoundState: TFpDwarfSubRangeBoundReadState;
661 FCountConst: Int64;
662 FCountValue: TFpDwarfSymbolValue;
663 FCountState: TFpDwarfSubRangeBoundReadState;
664 FLowEnumIdx, FHighEnumIdx: Integer;
665 FEnumIdxValid: Boolean;
666 procedure InitEnumIdx;
667 procedure ReadBounds(AValueObj: TFpDwarfValue);
668 protected
669 function DoGetNestedTypeInfo: TFpDwarfSymbolType;override;
670 function GetHasBounds: Boolean; override;
671 function GetOrdHighBound: Int64; override;
672 function GetOrdLowBound: Int64; override;
673
674 procedure NameNeeded; override;
675 procedure KindNeeded; override;
676 procedure SizeNeeded; override;
677 function GetMember(AIndex: Int64): TFpDbgSymbol; override;
678 function GetMemberCount: Integer; override;
679 function GetFlags: TDbgSymbolFlags; override;
680 procedure Init; override;
681 public
682 function GetValueBounds(AValueObj: TFpDwarfValue; out ALowBound,
683 AHighBound: Int64): Boolean; override;
684 procedure ResetValueBounds; override;
685 end;
686
687 { TFpDwarfSymbolTypePointer }
688
689 TFpDwarfSymbolTypePointer = class(TFpDwarfSymbolType)
690 private
691 FIsInternalPointer: Boolean;
692 function GetIsInternalPointer: Boolean; inline;
693 function IsInternalDynArrayPointer: Boolean; inline;
694 protected
695 procedure TypeInfoNeeded; override;
696 procedure KindNeeded; override;
697 procedure SizeNeeded; override;
698 procedure ForwardToSymbolNeeded; override;
699 function GetDataAddressNext(AValueObj: TFpDwarfValue; var AnAddress: TFpDbgMemLocation;
700 ATargetType: TFpDwarfSymbolType; ATargetCacheIndex: Integer): Boolean; override;
701 function GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue; override;
702 function DataSize: Integer; override;
703 public
704 property IsInternalPointer: Boolean read GetIsInternalPointer write FIsInternalPointer; // Class (also DynArray, but DynArray is handled without this)
705 end;
706
707 { TFpDwarfSymbolValueEnumMember }
708
709 TFpDwarfSymbolValueEnumMember = class(TFpDwarfSymbolValue)
710 FOrdinalValue: Int64;
711 FOrdinalValueRead, FHasOrdinalValue: Boolean;
712 procedure ReadOrdinalValue;
713 protected
714 procedure KindNeeded; override;
715 function GetHasOrdinalValue: Boolean; override;
716 function GetOrdinalValue: Int64; override;
717 procedure Init; override;
718 function GetValueObject: TFpDbgValue; override;
719 end;
720
721
722 { TFpDwarfSymbolTypeEnum }
723
724 TFpDwarfSymbolTypeEnum = class(TFpDwarfSymbolType)
725 private
726 FMembers: TFpDbgCircularRefCntObjList;
727 procedure CreateMembers;
728 protected
729 function GetTypedValueObject({%H-}ATypeCast: Boolean): TFpDwarfValue; override;
730 procedure KindNeeded; override;
731 function GetMember(AIndex: Int64): TFpDbgSymbol; override;
732 function GetMemberByName(AIndex: String): TFpDbgSymbol; override;
733 function GetMemberCount: Integer; override;
734
735 function GetHasBounds: Boolean; override;
736 function GetOrdHighBound: Int64; override;
737 function GetOrdLowBound: Int64; override;
738 public
739 destructor Destroy; override;
740 end;
741
742
743 { TFpDwarfSymbolTypeSet }
744
745 TFpDwarfSymbolTypeSet = class(TFpDwarfSymbolType)
746 protected
747 procedure KindNeeded; override;
748 function GetTypedValueObject({%H-}ATypeCast: Boolean): TFpDwarfValue; override;
749 function GetMemberCount: Integer; override;
750 function GetMember(AIndex: Int64): TFpDbgSymbol; override;
751 end;
752
753 (*
754 If not specified
755 .NestedTypeInfo --> copy of TypeInfo
756 .ParentTypeInfo --> nil
757
758 ParentTypeInfo: has a weak RefCount (only AddRef, if self has other refs)
759
760
761 AnObject = TFpDwarfSymbolValueVariable
762 |-- .TypeInfo --> TBar = TFpDwarfSymbolTypeStructure [*1]
763 |-- .ParentTypeInfo --> may point to subroutine, if param or local var // TODO
764
765 TBar = TFpDwarfSymbolTypeStructure
766 |-- .TypeInfo --> TBarBase = TFpDwarfSymbolTypeStructure
767
768 TBarBase = TFpDwarfSymbolTypeStructure
769 |-- .TypeInfo --> TOBject = TFpDwarfSymbolTypeStructure
770
771 TObject = TFpDwarfSymbolTypeStructure
772 |-- .TypeInfo --> nil
773
774
775 FField = TFpDwarfSymbolValueMember (declared in TBarBase)
776 |-- .TypeInfo --> Integer = TFpDwarfSymbolTypeBasic [*1]
777 |-- .ParentTypeInfo --> TBarBase
778
779 [*1] May have TFpDwarfSymbolTypeDeclaration or others
780 *)
781
782 { TFpDwarfSymbolValueMember }
783
784 TFpDwarfSymbolValueMember = class(TFpDwarfSymbolValueWithLocation)
785 protected
786 function GetValueAddress(AValueObj: TFpDwarfValue; out AnAddress: TFpDbgMemLocation): Boolean; override;
787 function HasAddress: Boolean; override;
788 end;
789
790 { TFpDwarfSymbolTypeStructure }
791
792 TFpDwarfSymbolTypeStructure = class(TFpDwarfSymbolType)
793 // record or class
794 private
795 FMembers: TFpDbgCircularRefCntObjList;
796 FLastChildByName: TFpDwarfSymbol;
797 FInheritanceInfo: TDwarfInformationEntry;
798 procedure CreateMembers;
799 procedure InitInheritanceInfo; inline;
800 protected
801 function DoGetNestedTypeInfo: TFpDwarfSymbolType; override;
802 procedure KindNeeded; override;
803 function GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue; override;
804
805 // GetMember, if AIndex > Count then parent
806 function GetMember(AIndex: Int64): TFpDbgSymbol; override;
807 function GetMemberByName(AIndex: String): TFpDbgSymbol; override;
808 function GetMemberCount: Integer; override;
809
810 function GetDataAddressNext(AValueObj: TFpDwarfValue; var AnAddress: TFpDbgMemLocation;
811 ATargetType: TFpDwarfSymbolType; ATargetCacheIndex: Integer): Boolean; override;
812 public
813 destructor Destroy; override;
814 end;
815
816 { TFpDwarfSymbolTypeArray }
817
818 TFpDwarfSymbolTypeArray = class(TFpDwarfSymbolType)
819 private
820 FMembers: TFpDbgCircularRefCntObjList;
821 FRowMajor: Boolean;
822 FStrideInBits: Int64;
823 FDwarfArrayReadFlags: set of (didtStrideRead, didtOrdering);
824 procedure CreateMembers;
825 procedure ReadStride;
826 procedure ReadOrdering;
827 protected
828 procedure KindNeeded; override;
829 function GetTypedValueObject({%H-}ATypeCast: Boolean): TFpDwarfValue; override;
830
831 function GetFlags: TDbgSymbolFlags; override;
832 // GetMember: returns the TYPE/range of each index. NOT the data
833 function GetMember(AIndex: Int64): TFpDbgSymbol; override;
834 function GetMemberByName({%H-}AIndex: String): TFpDbgSymbol; override;
835 function GetMemberCount: Integer; override;
836 function GetMemberAddress(AValObject: TFpDwarfValue; const AIndex: Array of Int64): TFpDbgMemLocation;
837 public
838 destructor Destroy; override;
839 procedure ResetValueBounds; override;
840 end;
841
842 { TFpDwarfSymbolValueProc }
843
844 TFpDwarfSymbolValueProc = class(TFpDwarfSymbolValue)
845 private
846 //FCU: TDwarfCompilationUnit;
847 FProcMembers: TRefCntObjList; // Locals
848 FLastMember: TFpDbgSymbol;
849 FAddress: TDbgPtr;
850 FAddressInfo: PDwarfAddressInfo;
851 FStateMachine: TDwarfLineInfoStateMachine;
852 FFrameBaseParser: TDwarfLocationExpression;
853 FSelfParameter: TFpDwarfValue;
854 function StateMachineValid: Boolean;
855 function ReadVirtuality(out AFlags: TDbgSymbolFlags): Boolean;
856 procedure CreateMembers;
857 protected
858 function GetMember(AIndex: Int64): TFpDbgSymbol; override;
859 function GetMemberByName(AIndex: String): TFpDbgSymbol; override;
860 function GetMemberCount: Integer; override;
861
862 function GetFrameBase(ASender: TDwarfLocationExpression): TDbgPtr;
863 procedure KindNeeded; override;
864 procedure SizeNeeded; override;
865 function GetFlags: TDbgSymbolFlags; override;
866
867 function GetColumn: Cardinal; override;
868 function GetFile: String; override;
869 // function GetFlags: TDbgSymbolFlags; override;
870 function GetLine: Cardinal; override;
871 function GetValueObject: TFpDbgValue; override;
872 public
873 constructor Create(ACompilationUnit: TDwarfCompilationUnit; AInfo: PDwarfAddressInfo; AAddress: TDbgPtr); overload;
874 destructor Destroy; override;
875 // TODO members = locals ?
876 function GetSelfParameter(AnAddress: TDbgPtr = 0): TFpDwarfValue;
877 end;
878
879 { TFpDwarfSymbolValueVariable }
880
881 TFpDwarfSymbolValueVariable = class(TFpDwarfSymbolValueWithLocation)
882 protected
883 function GetValueAddress(AValueObj: TFpDwarfValue; out AnAddress: TFpDbgMemLocation): Boolean; override;
884 function HasAddress: Boolean; override;
885 public
886 end;
887
888 { TFpDwarfSymbolValueParameter }
889
890 TFpDwarfSymbolValueParameter = class(TFpDwarfSymbolValueWithLocation)
891 protected
892 function GetValueAddress(AValueObj: TFpDwarfValue; out AnAddress: TFpDbgMemLocation): Boolean; override;
893 function HasAddress: Boolean; override;
894 function GetFlags: TDbgSymbolFlags; override;
895 public
896 end;
897
898 { TFpDwarfSymbolUnit }
899
900 TFpDwarfSymbolUnit = class(TFpDwarfSymbol)
901 private
902 FLastChildByName: TFpDbgSymbol;
903 protected
904 procedure Init; override;
905 function GetMemberByName(AIndex: String): TFpDbgSymbol; override;
906 public
907 destructor Destroy; override;
908 end;
909 {%endregion Symbol objects }
910
911 implementation
912
913 var
914 FPDBG_DWARF_VERBOSE, FPDBG_DWARF_ERRORS, FPDBG_DWARF_WARNINGS, FPDBG_DWARF_SEARCH, FPDBG_DWARF_DATA_WARNINGS: PLazLoggerLogGroup;
915
916 { TFpDwarfDefaultSymbolClassMap }
917
918 class function TFpDwarfDefaultSymbolClassMap.HandleCompUnit(ACU: TDwarfCompilationUnit): Boolean;
919 begin
920 Result := True;
921 end;
922
923 class function TFpDwarfDefaultSymbolClassMap.GetDwarfSymbolClass(ATag: Cardinal): TDbgDwarfSymbolBaseClass;
924 begin
925 case ATag of
926 // TODO:
927 DW_TAG_constant:
928 Result := TFpDwarfSymbolValue;
929 DW_TAG_string_type,
930 DW_TAG_union_type, DW_TAG_ptr_to_member_type,
931 DW_TAG_file_type,
932 DW_TAG_thrown_type, DW_TAG_subroutine_type:
933 Result := TFpDwarfSymbolType;
934
935 // Type types
936 DW_TAG_packed_type,
937 DW_TAG_const_type,
938 DW_TAG_volatile_type: Result := TFpDwarfSymbolTypeModifier;
939 DW_TAG_reference_type: Result := TFpDwarfSymbolTypeRef;
940 DW_TAG_typedef: Result := TFpDwarfSymbolTypeDeclaration;
941 DW_TAG_pointer_type: Result := TFpDwarfSymbolTypePointer;
942
943 DW_TAG_base_type: Result := TFpDwarfSymbolTypeBasic;
944 DW_TAG_subrange_type: Result := TFpDwarfSymbolTypeSubRange;
945 DW_TAG_enumeration_type: Result := TFpDwarfSymbolTypeEnum;
946 DW_TAG_enumerator: Result := TFpDwarfSymbolValueEnumMember;
947 DW_TAG_set_type: Result := TFpDwarfSymbolTypeSet;
948 DW_TAG_structure_type,
949 DW_TAG_class_type: Result := TFpDwarfSymbolTypeStructure;
950 DW_TAG_array_type: Result := TFpDwarfSymbolTypeArray;
951 // Value types
952 DW_TAG_variable: Result := TFpDwarfSymbolValueVariable;
953 DW_TAG_formal_parameter: Result := TFpDwarfSymbolValueParameter;
954 DW_TAG_member: Result := TFpDwarfSymbolValueMember;
955 DW_TAG_subprogram: Result := TFpDwarfSymbolValueProc;
956 //
957 DW_TAG_compile_unit: Result := TFpDwarfSymbolUnit;
958
959 else
960 Result := TFpDwarfSymbol;
961 end;
962 end;
963
964 class function TFpDwarfDefaultSymbolClassMap.CreateContext(AThreadId, AStackFrame: Integer;
965 AnAddress: TDbgPtr; ASymbol: TFpDbgSymbol; ADwarf: TFpDwarfInfo): TFpDbgInfoContext;
966 begin
967 Result := TFpDwarfInfoAddressContext.Create(AThreadId, AStackFrame, AnAddress, ASymbol, ADwarf);
968 end;
969
970 class function TFpDwarfDefaultSymbolClassMap.CreateProcSymbol(ACompilationUnit: TDwarfCompilationUnit;
971 AInfo: PDwarfAddressInfo; AAddress: TDbgPtr): TDbgDwarfSymbolBase;
972 begin
973 Result := TFpDwarfSymbolValueProc.Create(ACompilationUnit, AInfo, AAddress);
974 end;
975
976 { TDbgDwarfInfoAddressContext }
977
GetSymbolAtAddressnull978 function TFpDwarfInfoAddressContext.GetSymbolAtAddress: TFpDbgSymbol;
979 begin
980 Result := FSymbol;
981 end;
982
GetProcedureAtAddressnull983 function TFpDwarfInfoAddressContext.GetProcedureAtAddress: TFpDbgValue;
984 begin
985 Result := inherited GetProcedureAtAddress;
986 ApplyContext(Result);
987 end;
988
GetAddressnull989 function TFpDwarfInfoAddressContext.GetAddress: TDbgPtr;
990 begin
991 Result := FAddress;
992 end;
993
GetThreadIdnull994 function TFpDwarfInfoAddressContext.GetThreadId: Integer;
995 begin
996 Result := FThreadId;
997 end;
998
GetStackFramenull999 function TFpDwarfInfoAddressContext.GetStackFrame: Integer;
1000 begin
1001 Result := FStackFrame;
1002 end;
1003
GetSizeOfAddressnull1004 function TFpDwarfInfoAddressContext.GetSizeOfAddress: Integer;
1005 begin
1006 assert(FSymbol is TFpDwarfSymbol, 'TDbgDwarfInfoAddressContext.GetSizeOfAddress');
1007 Result := TFpDwarfSymbol(FSymbol).CompilationUnit.AddressSize;
1008 end;
1009
GetMemManagernull1010 function TFpDwarfInfoAddressContext.GetMemManager: TFpDbgMemManager;
1011 begin
1012 Result := FDwarf.MemManager;
1013 end;
1014
1015 procedure TFpDwarfInfoAddressContext.ApplyContext(AVal: TFpDbgValue);
1016 begin
1017 if (AVal <> nil) and (TFpDwarfValueBase(AVal).FContext = nil) then
1018 TFpDwarfValueBase(AVal).FContext := Self;
1019 end;
1020
SymbolToValuenull1021 function TFpDwarfInfoAddressContext.SymbolToValue(ASym: TFpDbgSymbol): TFpDbgValue;
1022 begin
1023 if ASym = nil then begin
1024 Result := nil;
1025 exit;
1026 end;
1027
1028 if ASym.SymbolType = stValue then begin
1029 Result := ASym.Value;
1030 if Result <> nil then
1031 Result.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FlastResult, 'FindSymbol'){$ENDIF};
1032 end
1033 else begin
1034 Result := TFpDwarfValueTypeDefinition.Create(ASym);
1035 {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(@FlastResult, 'FindSymbol'){$ENDIF};
1036 end;
1037 ASym.ReleaseReference;
1038 end;
1039
1040 procedure TFpDwarfInfoAddressContext.AddRefToVal(AVal: TFpDbgValue);
1041 begin
1042 AVal.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FlastResult, 'FindSymbol'){$ENDIF};
1043 end;
1044
GetSelfParameternull1045 function TFpDwarfInfoAddressContext.GetSelfParameter: TFpDbgValue;
1046 begin
1047 Result := TFpDwarfSymbolValueProc(FSymbol).GetSelfParameter(FAddress);
1048 if (Result <> nil) and (TFpDwarfValueBase(Result).FContext = nil) then
1049 TFpDwarfValueBase(Result).FContext := Self;
1050 end;
1051
FindExportedSymbolInUnitsnull1052 function TFpDwarfInfoAddressContext.FindExportedSymbolInUnits(const AName: String; PNameUpper,
1053 PNameLower: PChar; SkipCompUnit: TDwarfCompilationUnit; out ADbgValue: TFpDbgValue): Boolean;
1054 var
1055 i, ExtVal: Integer;
1056 CU: TDwarfCompilationUnit;
1057 InfoEntry, FoundInfoEntry: TDwarfInformationEntry;
1058 s: String;
1059 begin
1060 Result := False;
1061 ADbgValue := nil;
1062 InfoEntry := nil;
1063 FoundInfoEntry := nil;
1064 i := FDwarf.CompilationUnitsCount;
1065 while i > 0 do begin
1066 dec(i);
1067 CU := FDwarf.CompilationUnits[i];
1068 if CU = SkipCompUnit then
1069 continue;
1070 //DebugLn(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier search UNIT Name=', CU.FileName]);
1071
1072 InfoEntry.ReleaseReference;
1073 InfoEntry := TDwarfInformationEntry.Create(CU, nil);
1074 InfoEntry.ScopeIndex := CU.FirstScope.Index;
1075
1076 if not InfoEntry.AbbrevTag = DW_TAG_compile_unit then
1077 continue;
1078 // compile_unit can not have startscope
1079
1080 s := CU.UnitName;
1081 if (s <> '') and (CompareUtf8BothCase(PNameUpper, PNameLower, @s[1])) then begin
1082 ReleaseRefAndNil(FoundInfoEntry);
1083 ADbgValue := SymbolToValue(TFpDwarfSymbol.CreateSubClass(AName, InfoEntry));
1084 break;
1085 end;
1086
1087 CU.ScanAllEntries;
1088 if InfoEntry.GoNamedChildEx(PNameUpper, PNameLower) then begin
1089 if InfoEntry.IsAddressInStartScope(FAddress) then begin
1090 // only variables are marked "external", but types not / so we may need all top level
1091 FoundInfoEntry.ReleaseReference;
1092 FoundInfoEntry := InfoEntry.Clone;
1093 //DebugLn(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier MAYBE FOUND Name=', CU.FileName]);
1094
1095 // DW_AT_visibility ?
1096 if InfoEntry.ReadValue(DW_AT_external, ExtVal) then
1097 if ExtVal <> 0 then
1098 break;
1099 // Search for better ADbgValue
1100 end;
1101 end;
1102 end;
1103
1104 if FoundInfoEntry <> nil then begin;
1105 ADbgValue := SymbolToValue(TFpDwarfSymbol.CreateSubClass(AName, FoundInfoEntry));
1106 FoundInfoEntry.ReleaseReference;
1107 end;
1108
1109 InfoEntry.ReleaseReference;
1110 Result := ADbgValue <> nil;
1111 end;
1112
FindSymbolInStructurenull1113 function TFpDwarfInfoAddressContext.FindSymbolInStructure(const AName: String; PNameUpper,
1114 PNameLower: PChar; InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpDbgValue): Boolean;
1115 var
1116 InfoEntryInheritance: TDwarfInformationEntry;
1117 FwdInfoPtr: Pointer;
1118 FwdCompUint: TDwarfCompilationUnit;
1119 SelfParam: TFpDbgValue;
1120 begin
1121 Result := False;
1122 ADbgValue := nil;
1123 InfoEntry.AddReference;
1124
1125 while True do begin
1126 if not InfoEntry.IsAddressInStartScope(FAddress) then
1127 break;
1128
1129 InfoEntryInheritance := InfoEntry.FindChildByTag(DW_TAG_inheritance);
1130
1131 if InfoEntry.GoNamedChildEx(PNameUpper, PNameLower) then begin
1132 if InfoEntry.IsAddressInStartScope(FAddress) then begin
1133 SelfParam := GetSelfParameter;
1134 if (SelfParam <> nil) then begin
1135 // TODO: only valid, as long as context is valid, because if context is freed, then self is lost too
1136 ADbgValue := SelfParam.MemberByName[AName];
1137 assert(ADbgValue <> nil, 'FindSymbol: SelfParam.MemberByName[AName]');
1138 if ADbgValue <> nil then
1139 ADbgValue.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FlastResult, 'FindSymbol'){$ENDIF};
1140 end
1141 else debugln(['TDbgDwarfInfoAddressContext.FindSymbol XXXXXXXXXXXXX no self']);
1142 ;
1143 if ADbgValue = nil then begin // Todo: abort the searh /SetError
1144 ADbgValue := SymbolToValue(TFpDwarfSymbol.CreateSubClass(AName, InfoEntry));
1145 end;
1146 InfoEntry.ReleaseReference;
1147 InfoEntryInheritance.ReleaseReference;
1148 Result := True;
1149 exit;
1150 end;
1151 end;
1152
1153
1154 if not( (InfoEntryInheritance <> nil) and
1155 (InfoEntryInheritance.ReadReference(DW_AT_type, FwdInfoPtr, FwdCompUint)) )
1156 then
1157 break;
1158 InfoEntry.ReleaseReference;
1159 InfoEntry := TDwarfInformationEntry.Create(FwdCompUint, FwdInfoPtr);
1160 InfoEntryInheritance.ReleaseReference;
1161 DebugLn(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier PARENT ', dbgs(InfoEntry, FwdCompUint) ]);
1162 end;
1163
1164 InfoEntry.ReleaseReference;
1165 Result := ADbgValue <> nil;
1166 end;
1167
FindLocalSymbolnull1168 function TFpDwarfInfoAddressContext.FindLocalSymbol(const AName: String; PNameUpper,
1169 PNameLower: PChar; InfoEntry: TDwarfInformationEntry; out ADbgValue: TFpDbgValue): Boolean;
1170 begin
1171 Result := False;
1172 ADbgValue := nil;
1173 if not InfoEntry.GoNamedChildEx(PNameUpper, PNameLower) then
1174 exit;
1175 if InfoEntry.IsAddressInStartScope(FAddress) and not InfoEntry.IsArtificial then begin
1176 ADbgValue := SymbolToValue(TFpDwarfSymbol.CreateSubClass(AName, InfoEntry));
1177 if ADbgValue <> nil then
1178 TFpDwarfSymbol(ADbgValue.DbgSymbol).ParentTypeInfo := TFpDwarfSymbolValueProc(FSymbol);
1179 end;
1180 Result := ADbgValue <> nil;
1181 end;
1182
1183 constructor TFpDwarfInfoAddressContext.Create(AThreadId, AStackFrame: Integer;
1184 AnAddress: TDbgPtr; ASymbol: TFpDbgSymbol; ADwarf: TFpDwarfInfo);
1185 begin
1186 inherited Create;
1187 AddReference;
1188 FAddress := AnAddress;
1189 FThreadId := AThreadId;
1190 FStackFrame := AStackFrame;
1191 FDwarf := ADwarf;
1192 FSymbol := ASymbol;
1193 FSymbol.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSymbol, 'Context to Symbol'){$ENDIF};
1194 end;
1195
1196 destructor TFpDwarfInfoAddressContext.Destroy;
1197 begin
1198 FlastResult.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FlastResult, 'FindSymbol'){$ENDIF};
1199 FSymbol.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSymbol, 'Context to Symbol'){$ENDIF};
1200 inherited Destroy;
1201 end;
1202
FindSymbolnull1203 function TFpDwarfInfoAddressContext.FindSymbol(const AName: String): TFpDbgValue;
1204 var
1205 SubRoutine: TFpDwarfSymbolValueProc; // TDbgSymbol;
1206 CU: TDwarfCompilationUnit;
1207 //Scope,
1208 StartScopeIdx: Integer;
1209 InfoEntry: TDwarfInformationEntry;
1210 NameUpper, NameLower: String;
1211 InfoName: PChar;
1212 tg: Cardinal;
1213 PNameUpper, PNameLower: PChar;
1214 begin
1215 Result := nil;
1216 if (FSymbol = nil) or not(FSymbol is TFpDwarfSymbolValueProc) or (AName = '') then
1217 exit;
1218
1219 SubRoutine := TFpDwarfSymbolValueProc(FSymbol);
1220 NameUpper := UTF8UpperCase(AName);
1221 NameLower := UTF8LowerCase(AName);
1222 PNameUpper := @NameUpper[1];
1223 PNameLower := @NameLower[1];
1224
1225 try
1226 CU := SubRoutine.CompilationUnit;
1227 InfoEntry := SubRoutine.InformationEntry.Clone;
1228
1229 while InfoEntry.HasValidScope do begin
1230 //debugln(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier Searching ', dbgs(InfoEntry.FScope, CU)]);
1231 StartScopeIdx := InfoEntry.ScopeIndex;
1232
1233 //if InfoEntry.Abbrev = nil then
1234 // exit;
1235
1236 if not InfoEntry.IsAddressInStartScope(FAddress) // StartScope = first valid address
1237 then begin
1238 // CONTINUE: Search parent(s)
1239 //InfoEntry.ScopeIndex := StartScopeIdx;
1240 InfoEntry.GoParent;
1241 Continue;
1242 end;
1243
1244 if InfoEntry.ReadName(InfoName) and not InfoEntry.IsArtificial
1245 then begin
1246 if (CompareUtf8BothCase(PNameUpper, PNameLower, InfoName)) then begin
1247 // TODO: this is a pascal sperific search order? Or not?
1248 // If this is a type with a pointer or ref, need to find the pointer or ref.
1249 InfoEntry.GoParent;
1250 if InfoEntry.HasValidScope and
1251 InfoEntry.GoNamedChildEx(PNameUpper, PNameLower)
1252 then begin
1253 if InfoEntry.IsAddressInStartScope(FAddress) and not InfoEntry.IsArtificial then begin
1254 Result := SymbolToValue(TFpDwarfSymbol.CreateSubClass(AName, InfoEntry));
1255 exit;
1256 end;
1257 end;
1258
1259 InfoEntry.ScopeIndex := StartScopeIdx;
1260 Result := SymbolToValue(TFpDwarfSymbol.CreateSubClass(AName, InfoEntry));
1261 exit;
1262 end;
1263 end;
1264
1265
1266 tg := InfoEntry.AbbrevTag;
1267 if (tg = DW_TAG_class_type) or (tg = DW_TAG_structure_type) then begin
1268 if FindSymbolInStructure(AName,PNameUpper, PNameLower, InfoEntry, Result) then
1269 exit; // TODO: check error
1270 //InfoEntry.ScopeIndex := StartScopeIdx;
1271 end
1272
1273 else
1274 if (StartScopeIdx = SubRoutine.InformationEntry.ScopeIndex) then begin // searching in subroutine
1275 if FindLocalSymbol(AName,PNameUpper, PNameLower, InfoEntry, Result) then
1276 exit; // TODO: check error
1277 //InfoEntry.ScopeIndex := StartScopeIdx;
1278 end
1279 // TODO: nested subroutine
1280
1281 else
1282 if InfoEntry.GoNamedChildEx(PNameUpper, PNameLower) then begin
1283 if InfoEntry.IsAddressInStartScope(FAddress) and not InfoEntry.IsArtificial then begin
1284 Result := SymbolToValue(TFpDwarfSymbol.CreateSubClass(AName, InfoEntry));
1285 exit;
1286 end;
1287 end;
1288
1289 // Search parent(s)
1290 InfoEntry.ScopeIndex := StartScopeIdx;
1291 InfoEntry.GoParent;
1292 end;
1293
1294 FindExportedSymbolInUnits(AName, PNameUpper, PNameLower, CU, Result);
1295
1296 finally
1297 if (Result = nil) or (InfoEntry = nil)
1298 then DebugLn(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier NOT found Name=', AName])
1299 else DebugLn(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier(',AName,') found Scope=', TFpDwarfSymbol(Result.DbgSymbol).InformationEntry.ScopeDebugText, ' ResultSymbol=', DbgSName(Result.DbgSymbol), ' ', Result.DbgSymbol.Name, ' in ', TFpDwarfSymbol(Result.DbgSymbol).CompilationUnit.FileName]);
1300 ReleaseRefAndNil(InfoEntry);
1301
1302 FlastResult.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FlastResult, 'FindSymbol'){$ENDIF};
1303 FlastResult := Result;
1304
1305 assert((Result = nil) or (Result is TFpDwarfValueBase), 'TDbgDwarfInfoAddressContext.FindSymbol: (Result = nil) or (Result is TFpDwarfValueBase)');
1306 ApplyContext(Result);
1307 end;
1308 end;
1309
1310 { TFpDwarfValueTypeDefinition }
1311
GetKindnull1312 function TFpDwarfValueTypeDefinition.GetKind: TDbgSymbolKind;
1313 begin
1314 Result := skNone;
1315 end;
1316
GetDbgSymbolnull1317 function TFpDwarfValueTypeDefinition.GetDbgSymbol: TFpDbgSymbol;
1318 begin
1319 Result := FSymbol;
1320 end;
1321
1322 constructor TFpDwarfValueTypeDefinition.Create(ASymbol: TFpDbgSymbol);
1323 begin
1324 inherited Create;
1325 FSymbol := ASymbol;
1326 FSymbol.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSymbol, 'TFpDwarfValueTypeDefinition'){$ENDIF};
1327 end;
1328
1329 destructor TFpDwarfValueTypeDefinition.Destroy;
1330 begin
1331 inherited Destroy;
1332 FSymbol.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSymbol, 'TFpDwarfValueTypeDefinition'){$ENDIF};
1333 end;
1334
GetTypeCastedValuenull1335 function TFpDwarfValueTypeDefinition.GetTypeCastedValue(ADataVal: TFpDbgValue): TFpDbgValue;
1336 begin
1337 Result := FSymbol.TypeCastValue(ADataVal);
1338 assert((Result = nil) or (Result is TFpDwarfValue), 'TFpDwarfValueTypeDefinition.GetTypeCastedValue: (Result = nil) or (Result is TFpDwarfValue)');
1339 if (Result <> nil) and (TFpDwarfValue(Result).FContext = nil) then
1340 TFpDwarfValue(Result).FContext := FContext;
1341 end;
1342
1343 { TFpDwarfValue }
1344
MemManagernull1345 function TFpDwarfValue.MemManager: TFpDbgMemManager;
1346 begin
1347 Result := nil;
1348 if FContext <> nil then
1349 Result := FContext.MemManager;
1350
1351 if Result = nil then begin
1352 // Either a typecast, or a member gotten from a typecast,...
1353 assert((FOwner <> nil) and (FOwner.CompilationUnit <> nil) and (FOwner.CompilationUnit.Owner <> nil), 'TDbgDwarfSymbolValue.MemManager');
1354 Result := FOwner.CompilationUnit.Owner.MemManager;
1355 end;
1356 end;
1357
GetDataAddressCachenull1358 function TFpDwarfValue.GetDataAddressCache(AIndex: Integer): TFpDbgMemLocation;
1359 begin
1360 if AIndex < Length(FDataAddressCache) then
1361 Result := FDataAddressCache[AIndex]
1362 else
1363 Result := UnInitializedLoc;
1364 end;
1365
AddressSizenull1366 function TFpDwarfValue.AddressSize: Byte;
1367 begin
1368 assert((FOwner <> nil) and (FOwner.CompilationUnit <> nil), 'TDbgDwarfSymbolValue.AddressSize');
1369 Result := FOwner.CompilationUnit.AddressSize;
1370 end;
1371
1372 procedure TFpDwarfValue.SetDataAddressCache(AIndex: Integer; AValue: TFpDbgMemLocation);
1373 var
1374 i, j: Integer;
1375 begin
1376 i := length(FDataAddressCache);
1377 if AIndex >= i then begin
1378 SetLength(FDataAddressCache, AIndex + 1 + 8);
1379 // todo: Fillbyte 0
1380 for j := i to Length(FDataAddressCache) - 1 do
1381 FDataAddressCache[j] := UnInitializedLoc;
1382 end;
1383 FDataAddressCache[AIndex] := AValue;
1384 end;
1385
1386 procedure TFpDwarfValue.SetStructureValue(AValue: TFpDwarfValue);
1387 begin
1388 if FStructureValue <> nil then
1389 Reset;
1390
1391 if FStructureValue = AValue then
1392 exit;
1393
1394 if CircleBackRefsActive and (FStructureValue <> nil) then
1395 FStructureValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FStructureValue, 'TDbgDwarfSymbolValue'){$ENDIF};
1396 FStructureValue := AValue;
1397 if CircleBackRefsActive and (FStructureValue <> nil) then
1398 FStructureValue.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FStructureValue, 'TDbgDwarfSymbolValue'){$ENDIF};
1399 end;
1400
GetLastErrornull1401 function TFpDwarfValue.GetLastError: TFpError;
1402 begin
1403 Result := FLastError;
1404 end;
1405
DataAddrnull1406 function TFpDwarfValue.DataAddr: TFpDbgMemLocation;
1407 begin
1408 // GetDwarfDataAddress(???); What about FTypeCastSourceValue.AsCardinal ?
1409 if FValueSymbol <> nil then begin
1410 //FValueSymbol.GetValueAddress(Self, Result);
1411 FValueSymbol.GetValueDataAddress(Self, Result, FOwner);
1412 if IsError(FValueSymbol.LastError) then
1413 FLastError := FValueSymbol.LastError;
1414 end
1415 else
1416 if HasTypeCastInfo then begin
1417 Result := FTypeCastSourceValue.Address;
1418 if IsError(FTypeCastSourceValue.LastError) then
1419 FLastError := FTypeCastSourceValue.LastError;
1420
1421 if IsReadableLoc(Result) then begin
1422 if not FTypeCastTargetType.GetDataAddress(Self, Result, FOwner, 1) then
1423 Result := InvalidLoc;
1424 if IsError(FTypeCastTargetType.LastError) then
1425 FLastError := FTypeCastTargetType.LastError;
1426 end;
1427 end
1428 else
1429 Result := InvalidLoc;
1430 end;
1431
OrdOrDataAddrnull1432 function TFpDwarfValue.OrdOrDataAddr: TFpDbgMemLocation;
1433 begin
1434 if HasTypeCastInfo and (svfOrdinal in FTypeCastSourceValue.FieldFlags) then
1435 Result := ConstLoc(FTypeCastSourceValue.AsCardinal)
1436 else
1437 Result := DataAddr;
1438 end;
1439
GetDwarfDataAddressnull1440 function TFpDwarfValue.GetDwarfDataAddress(out AnAddress: TFpDbgMemLocation;
1441 ATargetType: TFpDwarfSymbolType): Boolean;
1442 var
1443 fields: TFpDbgValueFieldFlags;
1444 begin
1445 if FValueSymbol <> nil then begin
1446 Assert(FValueSymbol is TFpDwarfSymbolValue, 'TDbgDwarfSymbolValue.GetDwarfDataAddress FValueSymbol');
1447 Assert(TypeInfo is TFpDwarfSymbolType, 'TDbgDwarfSymbolValue.GetDwarfDataAddress TypeInfo');
1448 Assert(not HasTypeCastInfo, 'TDbgDwarfSymbolValue.GetDwarfDataAddress not HasTypeCastInfo');
1449 Result := FValueSymbol.GetValueDataAddress(Self, AnAddress, ATargetType);
1450 if IsError(FValueSymbol.LastError) then
1451 FLastError := FValueSymbol.LastError;
1452 end
1453
1454 else
1455 begin
1456 // TODO: cache own address
1457 // try typecast
1458 Result := HasTypeCastInfo;
1459 if not Result then
1460 exit;
1461 fields := FTypeCastSourceValue.FieldFlags;
1462 AnAddress := InvalidLoc;
1463 if svfOrdinal in fields then
1464 AnAddress := ConstLoc(FTypeCastSourceValue.AsCardinal)
1465 else
1466 if svfAddress in fields then
1467 AnAddress := FTypeCastSourceValue.Address;
1468
1469 Result := IsReadableLoc(AnAddress);
1470 if not Result then
1471 exit;
1472
1473 Result := FTypeCastTargetType.GetDataAddress(Self, AnAddress, ATargetType, 1);
1474 if IsError(FTypeCastTargetType.LastError) then
1475 FLastError := FTypeCastTargetType.LastError;
1476 end;
1477 end;
1478
GetStructureDwarfDataAddressnull1479 function TFpDwarfValue.GetStructureDwarfDataAddress(out AnAddress: TFpDbgMemLocation;
1480 ATargetType: TFpDwarfSymbolType): Boolean;
1481 begin
1482 AnAddress := InvalidLoc;
1483 Result := StructureValue <> nil;
1484 if Result then
1485 Result := StructureValue.GetDwarfDataAddress(AnAddress, ATargetType);
1486 end;
1487
HasDwarfDataAddressnull1488 function TFpDwarfValue.HasDwarfDataAddress: Boolean;
1489 begin
1490 if FValueSymbol <> nil then begin
1491 Assert(FValueSymbol is TFpDwarfSymbolValue, 'TDbgDwarfSymbolValue.GetDwarfDataAddress FValueSymbol');
1492 Assert(TypeInfo is TFpDwarfSymbolType, 'TDbgDwarfSymbolValue.GetDwarfDataAddress TypeInfo');
1493 Assert(not HasTypeCastInfo, 'TDbgDwarfSymbolValue.GetDwarfDataAddress not HasTypeCastInfo');
1494 Result := FValueSymbol.HasAddress;
1495 end
1496 else
1497 begin
1498 // try typecast
1499 Result := HasTypeCastInfo;
1500 if not Result then
1501 exit;
1502 Result := FTypeCastSourceValue.FieldFlags * [svfAddress, svfOrdinal] <> [];
1503 end;
1504 end;
1505
1506 procedure TFpDwarfValue.Reset;
1507 begin
1508 FDataAddressCache := nil;
1509 FLastError := NoError;
1510 end;
1511
GetFieldFlagsnull1512 function TFpDwarfValue.GetFieldFlags: TFpDbgValueFieldFlags;
1513 begin
1514 Result := inherited GetFieldFlags;
1515 if FValueSymbol <> nil then begin
1516 if FValueSymbol.HasAddress then Result := Result + [svfAddress];
1517 end
1518 else
1519 if HasTypeCastInfo then begin
1520 Result := Result + FTypeCastSourceValue.FieldFlags * [svfAddress];
1521 end;
1522 end;
1523
HasTypeCastInfonull1524 function TFpDwarfValue.HasTypeCastInfo: Boolean;
1525 begin
1526 Result := (FTypeCastTargetType <> nil) and (FTypeCastSourceValue <> nil);
1527 end;
1528
IsValidTypeCastnull1529 function TFpDwarfValue.IsValidTypeCast: Boolean;
1530 begin
1531 Result := False;
1532 end;
1533
1534 procedure TFpDwarfValue.DoReferenceAdded;
1535 begin
1536 inherited DoReferenceAdded;
1537 DoPlainReferenceAdded;
1538 end;
1539
1540 procedure TFpDwarfValue.DoReferenceReleased;
1541 begin
1542 inherited DoReferenceReleased;
1543 DoPlainReferenceReleased;
1544 end;
1545
1546 procedure TFpDwarfValue.CircleBackRefActiveChanged(NewActive: Boolean);
1547 begin
1548 inherited CircleBackRefActiveChanged(NewActive);
1549 if NewActive then;
1550 if CircleBackRefsActive then begin
1551 if FValueSymbol <> nil then
1552 FValueSymbol.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValueSymbol, 'TDbgDwarfSymbolValue'){$ENDIF};
1553 if FStructureValue <> nil then
1554 FStructureValue.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FStructureValue, 'TDbgDwarfSymbolValue'){$ENDIF};
1555 end
1556 else begin
1557 if FValueSymbol <> nil then
1558 FValueSymbol.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValueSymbol, 'TDbgDwarfSymbolValue'){$ENDIF};
1559 if FStructureValue <> nil then
1560 FStructureValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FStructureValue, 'TDbgDwarfSymbolValue'){$ENDIF};
1561 end;
1562 end;
1563
1564 procedure TFpDwarfValue.SetLastMember(ALastMember: TFpDwarfValue);
1565 begin
1566 if FLastMember <> nil then
1567 FLastMember.ReleaseCirclularReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FLastMember, 'TDbgDwarfSymbolValue'){$ENDIF};
1568
1569 FLastMember := ALastMember;
1570
1571 if (FLastMember <> nil) then begin
1572 FLastMember.SetStructureValue(Self);
1573 FLastMember.AddCirclularReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FLastMember, 'TDbgDwarfSymbolValue'){$ENDIF};
1574 if (FLastMember.FContext = nil) then
1575 FLastMember.FContext := FContext;
1576 end;
1577 end;
1578
GetKindnull1579 function TFpDwarfValue.GetKind: TDbgSymbolKind;
1580 begin
1581 if FValueSymbol <> nil then
1582 Result := FValueSymbol.Kind
1583 else
1584 if HasTypeCastInfo then
1585 Result := FTypeCastTargetType.Kind
1586 else
1587 Result := inherited GetKind;
1588 end;
1589
GetAddressnull1590 function TFpDwarfValue.GetAddress: TFpDbgMemLocation;
1591 begin
1592 if FValueSymbol <> nil then
1593 FValueSymbol.GetValueAddress(Self, Result)
1594 else
1595 if HasTypeCastInfo then
1596 Result := FTypeCastSourceValue.Address
1597 else
1598 Result := inherited GetAddress;
1599 end;
1600
OrdOrAddressnull1601 function TFpDwarfValue.OrdOrAddress: TFpDbgMemLocation;
1602 begin
1603 if HasTypeCastInfo and (svfOrdinal in FTypeCastSourceValue.FieldFlags) then
1604 Result := ConstLoc(FTypeCastSourceValue.AsCardinal)
1605 else
1606 Result := Address;
1607 end;
1608
GetMemberCountnull1609 function TFpDwarfValue.GetMemberCount: Integer;
1610 begin
1611 if FValueSymbol <> nil then
1612 Result := FValueSymbol.MemberCount
1613 else
1614 Result := inherited GetMemberCount;
1615 end;
1616
GetMemberByNamenull1617 function TFpDwarfValue.GetMemberByName(AIndex: String): TFpDbgValue;
1618 var
1619 m: TFpDbgSymbol;
1620 begin
1621 Result := nil;
1622 if FValueSymbol <> nil then begin
1623 m := FValueSymbol.MemberByName[AIndex];
1624 if m <> nil then
1625 Result := m.Value;
1626 end;
1627 SetLastMember(TFpDwarfValue(Result));
1628 end;
1629
GetMembernull1630 function TFpDwarfValue.GetMember(AIndex: Int64): TFpDbgValue;
1631 var
1632 m: TFpDbgSymbol;
1633 begin
1634 Result := nil;
1635 if FValueSymbol <> nil then begin
1636 m := FValueSymbol.Member[AIndex];
1637 if m <> nil then
1638 Result := m.Value;
1639 end;
1640 SetLastMember(TFpDwarfValue(Result));
1641 end;
1642
GetDbgSymbolnull1643 function TFpDwarfValue.GetDbgSymbol: TFpDbgSymbol;
1644 begin
1645 Result := FValueSymbol;
1646 end;
1647
GetTypeInfonull1648 function TFpDwarfValue.GetTypeInfo: TFpDbgSymbol;
1649 begin
1650 if HasTypeCastInfo then
1651 Result := FTypeCastTargetType
1652 else
1653 Result := inherited GetTypeInfo;
1654 end;
1655
GetContextTypeInfonull1656 function TFpDwarfValue.GetContextTypeInfo: TFpDbgSymbol;
1657 begin
1658 if (FValueSymbol <> nil) and (FValueSymbol.ParentTypeInfo <> nil) then
1659 Result := FValueSymbol.ParentTypeInfo
1660 else
1661 Result := nil; // internal error
1662 end;
1663
1664 constructor TFpDwarfValue.Create(AOwner: TFpDwarfSymbolType);
1665 begin
1666 FOwner := AOwner;
1667 inherited Create;
1668 end;
1669
1670 destructor TFpDwarfValue.Destroy;
1671 begin
1672 FTypeCastTargetType.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeCastTargetType, ClassName+'.FTypeCastTargetType'){$ENDIF};
1673 FTypeCastSourceValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeCastSourceValue, ClassName+'.FTypeCastSourceValue'){$ENDIF};
1674 SetLastMember(nil);
1675 inherited Destroy;
1676 end;
1677
1678 procedure TFpDwarfValue.SetValueSymbol(AValueSymbol: TFpDwarfSymbolValue);
1679 begin
1680 if FValueSymbol = AValueSymbol then
1681 exit;
1682
1683 if CircleBackRefsActive and (FValueSymbol <> nil) then
1684 FValueSymbol.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValueSymbol, 'TDbgDwarfSymbolValue'){$ENDIF};
1685 FValueSymbol := AValueSymbol;
1686 if CircleBackRefsActive and (FValueSymbol <> nil) then
1687 FValueSymbol.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValueSymbol, 'TDbgDwarfSymbolValue'){$ENDIF};
1688 end;
1689
SetTypeCastInfonull1690 function TFpDwarfValue.SetTypeCastInfo(AStructure: TFpDwarfSymbolType;
1691 ASource: TFpDbgValue): Boolean;
1692 begin
1693 Reset;
1694 AStructure.ResetValueBounds;
1695
1696 if FTypeCastSourceValue <> ASource then begin
1697 if FTypeCastSourceValue <> nil then
1698 FTypeCastSourceValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeCastSourceValue, ClassName+'.FTypeCastSourceValue'){$ENDIF};
1699 FTypeCastSourceValue := ASource;
1700 if FTypeCastSourceValue <> nil then
1701 FTypeCastSourceValue.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeCastSourceValue, ClassName+'.FTypeCastSourceValue'){$ENDIF};
1702 end;
1703
1704 if FTypeCastTargetType <> AStructure then begin
1705 if FTypeCastTargetType <> nil then
1706 FTypeCastTargetType.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeCastTargetType, ClassName+'.FTypeCastTargetType'){$ENDIF};
1707 FTypeCastTargetType := AStructure;
1708 if FTypeCastTargetType <> nil then
1709 FTypeCastTargetType.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeCastTargetType, ClassName+'.FTypeCastTargetType'){$ENDIF};
1710 end;
1711
1712 Result := IsValidTypeCast;
1713 end;
1714
1715 { TFpDwarfValueSized }
1716
CanUseTypeCastAddressnull1717 function TFpDwarfValueSized.CanUseTypeCastAddress: Boolean;
1718 begin
1719 Result := True;
1720 if (FTypeCastSourceValue.FieldFlags * [svfAddress, svfSize, svfSizeOfPointer] = [svfAddress]) then
1721 exit
1722 else
1723 if (FTypeCastSourceValue.FieldFlags * [svfAddress, svfSize] = [svfAddress, svfSize]) and
1724 (FTypeCastSourceValue.Size = FSize) and (FSize > 0)
1725 then
1726 exit;
1727 if (FTypeCastSourceValue.FieldFlags * [svfAddress, svfSizeOfPointer] = [svfAddress, svfSizeOfPointer]) and
1728 not ( (FTypeCastTargetType.Kind = skPointer) //or
1729 //(FSize = AddressSize xxxxxxx)
1730 )
1731 then
1732 exit;
1733 Result := False;
1734 end;
1735
GetFieldFlagsnull1736 function TFpDwarfValueSized.GetFieldFlags: TFpDbgValueFieldFlags;
1737 begin
1738 Result := inherited GetFieldFlags;
1739 Result := Result + [svfSize];
1740 end;
1741
GetSizenull1742 function TFpDwarfValueSized.GetSize: Integer;
1743 begin
1744 Result := FSize;
1745 end;
1746
1747 constructor TFpDwarfValueSized.Create(AOwner: TFpDwarfSymbolType; ASize: Integer);
1748 begin
1749 inherited Create(AOwner);
1750 FSize := ASize;
1751 end;
1752
1753 { TFpDwarfValueNumeric }
1754
1755 procedure TFpDwarfValueNumeric.Reset;
1756 begin
1757 inherited Reset;
1758 FEvaluated := [];
1759 end;
1760
GetFieldFlagsnull1761 function TFpDwarfValueNumeric.GetFieldFlags: TFpDbgValueFieldFlags;
1762 begin
1763 Result := inherited GetFieldFlags;
1764 Result := Result + [svfOrdinal];
1765 end;
1766
IsValidTypeCastnull1767 function TFpDwarfValueNumeric.IsValidTypeCast: Boolean;
1768 begin
1769 Result := HasTypeCastInfo;
1770 If not Result then
1771 exit;
1772 if (svfOrdinal in FTypeCastSourceValue.FieldFlags) or CanUseTypeCastAddress then
1773 exit;
1774 Result := False;
1775 end;
1776
1777 constructor TFpDwarfValueNumeric.Create(AOwner: TFpDwarfSymbolType; ASize: Integer);
1778 begin
1779 inherited Create(AOwner, ASize);
1780 FEvaluated := [];
1781 end;
1782
1783 { TFpDwarfValueInteger }
1784
GetFieldFlagsnull1785 function TFpDwarfValueInteger.GetFieldFlags: TFpDbgValueFieldFlags;
1786 begin
1787 Result := inherited GetFieldFlags;
1788 Result := Result + [svfInteger];
1789 end;
1790
GetAsCardinalnull1791 function TFpDwarfValueInteger.GetAsCardinal: QWord;
1792 begin
1793 Result := QWord(GetAsInteger); // include sign extension
1794 end;
1795
GetAsIntegernull1796 function TFpDwarfValueInteger.GetAsInteger: Int64;
1797 begin
1798 if doneInt in FEvaluated then begin
1799 Result := FIntValue;
1800 exit;
1801 end;
1802 Include(FEvaluated, doneInt);
1803
1804 if (FSize <= 0) or (FSize > SizeOf(Result)) then
1805 Result := inherited GetAsInteger
1806 else
1807 if not MemManager.ReadSignedInt(OrdOrDataAddr, FSize, Result) then begin
1808 Result := 0; // TODO: error
1809 FLastError := MemManager.LastError;
1810 end;
1811
1812 FIntValue := Result;
1813 end;
1814
1815 { TDbgDwarfCardinalSymbolValue }
1816
GetAsCardinalnull1817 function TFpDwarfValueCardinal.GetAsCardinal: QWord;
1818 begin
1819 if doneUInt in FEvaluated then begin
1820 Result := FValue;
1821 exit;
1822 end;
1823 Include(FEvaluated, doneUInt);
1824
1825 if (FSize <= 0) or (FSize > SizeOf(Result)) then
1826 Result := inherited GetAsCardinal
1827 else
1828 if not MemManager.ReadUnsignedInt(OrdOrDataAddr, FSize, Result) then begin
1829 Result := 0; // TODO: error
1830 FLastError := MemManager.LastError;
1831 end;
1832
1833 FValue := Result;
1834 end;
1835
GetFieldFlagsnull1836 function TFpDwarfValueCardinal.GetFieldFlags: TFpDbgValueFieldFlags;
1837 begin
1838 Result := inherited GetFieldFlags;
1839 Result := Result + [svfCardinal];
1840 end;
1841
1842 { TFpDwarfValueFloat }
1843
GetFieldFlagsnull1844 function TFpDwarfValueFloat.GetFieldFlags: TFpDbgValueFieldFlags;
1845 begin
1846 Result := inherited GetFieldFlags;
1847 Result := Result + [svfFloat] - [svfOrdinal];
1848 end;
1849
GetAsFloatnull1850 function TFpDwarfValueFloat.GetAsFloat: Extended;
1851 begin
1852 if doneFloat in FEvaluated then begin
1853 Result := FValue;
1854 exit;
1855 end;
1856 Include(FEvaluated, doneUInt);
1857
1858 if (FSize <= 0) or (FSize > SizeOf(Result)) then
1859 Result := inherited GetAsCardinal
1860 else
1861 if not MemManager.ReadFloat(OrdOrDataAddr, FSize, Result) then begin
1862 Result := 0; // TODO: error
1863 FLastError := MemManager.LastError;
1864 end;
1865
1866 FValue := Result;
1867 end;
1868
1869 { TFpDwarfValueBoolean }
1870
GetFieldFlagsnull1871 function TFpDwarfValueBoolean.GetFieldFlags: TFpDbgValueFieldFlags;
1872 begin
1873 Result := inherited GetFieldFlags;
1874 Result := Result + [svfBoolean];
1875 end;
1876
GetAsBoolnull1877 function TFpDwarfValueBoolean.GetAsBool: Boolean;
1878 begin
1879 Result := QWord(GetAsCardinal) <> 0;
1880 end;
1881
1882 { TFpDwarfValueChar }
1883
GetFieldFlagsnull1884 function TFpDwarfValueChar.GetFieldFlags: TFpDbgValueFieldFlags;
1885 begin
1886 Result := inherited GetFieldFlags;
1887 case FSize of
1888 1: Result := Result + [svfString];
1889 2: Result := Result + [svfWideString];
1890 end;
1891 end;
1892
GetAsStringnull1893 function TFpDwarfValueChar.GetAsString: AnsiString;
1894 begin
1895 // Can typecast, because of FSize = 1, GetAsCardinal only read one byte
1896 if FSize = 2 then
1897 Result := GetAsWideString // temporary workaround for WideChar
1898 else
1899 if FSize <> 1 then
1900 Result := inherited GetAsString
1901 else
1902 Result := SysToUTF8(char(byte(GetAsCardinal)));
1903 end;
1904
GetAsWideStringnull1905 function TFpDwarfValueChar.GetAsWideString: WideString;
1906 begin
1907 if FSize > 2 then
1908 Result := inherited GetAsWideString
1909 else
1910 Result := WideChar(Word(GetAsCardinal));
1911 end;
1912
1913 { TFpDwarfValuePointer }
1914
GetAsCardinalnull1915 function TFpDwarfValuePointer.GetAsCardinal: QWord;
1916 var
1917 a: TFpDbgMemLocation;
1918 begin
1919 a := GetDataAddress;
1920 if IsTargetAddr(a) then
1921 Result := LocToAddr(a)
1922 else
1923 Result := 0;
1924 end;
1925
GetFieldFlagsnull1926 function TFpDwarfValuePointer.GetFieldFlags: TFpDbgValueFieldFlags;
1927 var
1928 t: TFpDbgSymbol;
1929 begin
1930 Result := inherited GetFieldFlags;
1931 //TODO: svfDataAddress should depend on (hidden) Pointer or Ref in the TypeInfo
1932 Result := Result + [svfCardinal, svfOrdinal, svfSizeOfPointer, svfDataAddress] - [svfSize]; // data address
1933
1934 t := TypeInfo;
1935 if (t <> nil) then t := t.TypeInfo;
1936 if (t <> nil) and (t.Kind = skChar) and IsReadableMem(DataAddress) then // pchar
1937 Result := Result + [svfString]; // data address
1938 end;
1939
GetDataAddressnull1940 function TFpDwarfValuePointer.GetDataAddress: TFpDbgMemLocation;
1941 begin
1942 if doneAddr in FEvaluated then begin
1943 Result := FPointetToAddr;
1944 exit;
1945 end;
1946 Include(FEvaluated, doneAddr);
1947
1948 if (FSize <= 0) then
1949 Result := InvalidLoc
1950 else
1951 begin
1952 if not MemManager.ReadAddress(OrdOrDataAddr, FSize, Result) then
1953 FLastError := MemManager.LastError;
1954 end;
1955
1956 FPointetToAddr := Result;
1957 end;
1958
GetAsStringnull1959 function TFpDwarfValuePointer.GetAsString: AnsiString;
1960 var
1961 t: TFpDbgSymbol;
1962 i: Integer;
1963 begin
1964 t := TypeInfo;
1965 if (t <> nil) then t := t.TypeInfo;
1966 if t.Size = 2 then
1967 Result := GetAsWideString
1968 else
1969 if (MemManager <> nil) and (t <> nil) and (t.Kind = skChar) and IsReadableMem(DataAddress) then begin // pchar
1970 SetLength(Result, 2000);
1971 i := 2000;
1972 while (i > 0) and (not MemManager.ReadMemory(DataAddress, i, @Result[1])) do
1973 i := i div 2;
1974 SetLength(Result,i);
1975 i := pos(#0, Result);
1976 if i > 0 then
1977 SetLength(Result,i-1);
1978 end
1979 else
1980 Result := inherited GetAsString;
1981 end;
1982
GetAsWideStringnull1983 function TFpDwarfValuePointer.GetAsWideString: WideString;
1984 var
1985 t: TFpDbgSymbol;
1986 i: Integer;
1987 begin
1988 t := TypeInfo;
1989 if (t <> nil) then t := t.TypeInfo;
1990 // skWideChar ???
1991 if (MemManager <> nil) and (t <> nil) and (t.Kind = skChar) and IsReadableMem(DataAddress) then begin // pchar
1992 SetLength(Result, 2000);
1993 i := 4000; // 2000 * 16 bit
1994 while (i > 0) and (not MemManager.ReadMemory(DataAddress, i, @Result[1])) do
1995 i := i div 2;
1996 SetLength(Result, i div 2);
1997 i := pos(#0, Result);
1998 if i > 0 then
1999 SetLength(Result, i-1);
2000 end
2001 else
2002 Result := inherited GetAsWideString;
2003 end;
2004
GetMembernull2005 function TFpDwarfValuePointer.GetMember(AIndex: Int64): TFpDbgValue;
2006 var
2007 ti: TFpDbgSymbol;
2008 addr: TFpDbgMemLocation;
2009 Tmp: TFpDwarfValueConstAddress;
2010 begin
2011 //TODO: ?? if no TypeInfo.TypeInfo;, then return TFpDwarfValueConstAddress.Create(addr); (for mem dump)
2012 Result := nil;
2013 ReleaseRefAndNil(FLastAddrMember);
2014 if (TypeInfo = nil) then begin // TODO dedicanted error code
2015 FLastError := CreateError(fpErrAnyError, ['Can not dereference an untyped pointer']);
2016 exit;
2017 end;
2018
2019 // TODO re-use last member
2020
2021 ti := TypeInfo.TypeInfo;
2022 {$PUSH}{$R-}{$Q-} // TODO: check overflow
2023 if ti <> nil then
2024 AIndex := AIndex * ti.Size;
2025 addr := DataAddress;
2026 if not IsTargetAddr(addr) then begin
2027 FLastError := CreateError(fpErrAnyError, ['Internal dereference error']);
2028 exit;
2029 end;
2030 addr.Address := addr.Address + AIndex;
2031 {$POP}
2032
2033 Tmp := TFpDwarfValueConstAddress.Create(addr);
2034 if ti <> nil then begin
2035 Result := ti.TypeCastValue(Tmp);
2036 Tmp.ReleaseReference;
2037 SetLastMember(TFpDwarfValue(Result));
2038 Result.ReleaseReference;
2039 end
2040 else begin
2041 Result := Tmp;
2042 FLastAddrMember := Result;
2043 end;
2044 end;
2045
2046 destructor TFpDwarfValuePointer.Destroy;
2047 begin
2048 FLastAddrMember.ReleaseReference;
2049 inherited Destroy;
2050 end;
2051
2052 { TFpDwarfValueEnum }
2053
2054 procedure TFpDwarfValueEnum.InitMemberIndex;
2055 var
2056 v: QWord;
2057 i: Integer;
2058 begin
2059 // TODO: if TypeInfo is a subrange, check against the bounds, then bypass it, and scan all members (avoid subrange scanning members)
2060 if FMemberValueDone then exit;
2061 // FTypeCastTargetType (if not nil) must be same as FOwner. It may have wrappers like declaration.
2062 v := GetAsCardinal;
2063 i := FOwner.MemberCount - 1;
2064 while i >= 0 do begin
2065 if FOwner.Member[i].OrdinalValue = v then break;
2066 dec(i);
2067 end;
2068 FMemberIndex := i;
2069 FMemberValueDone := True;
2070 end;
2071
2072 procedure TFpDwarfValueEnum.Reset;
2073 begin
2074 inherited Reset;
2075 FMemberValueDone := False;
2076 end;
2077
GetFieldFlagsnull2078 function TFpDwarfValueEnum.GetFieldFlags: TFpDbgValueFieldFlags;
2079 begin
2080 Result := inherited GetFieldFlags;
2081 Result := Result + [svfOrdinal, svfMembers, svfIdentifier];
2082 end;
2083
GetAsCardinalnull2084 function TFpDwarfValueEnum.GetAsCardinal: QWord;
2085 begin
2086 if doneUInt in FEvaluated then begin
2087 Result := FValue;
2088 exit;
2089 end;
2090 Include(FEvaluated, doneUInt);
2091
2092 if (FSize <= 0) or (FSize > SizeOf(Result)) then
2093 Result := inherited GetAsCardinal
2094 else
2095 if not MemManager.ReadEnum(OrdOrDataAddr, FSize, Result) then begin
2096 FLastError := MemManager.LastError;
2097 Result := 0; // TODO: error
2098 end;
2099
2100 FValue := Result;
2101 end;
2102
GetAsStringnull2103 function TFpDwarfValueEnum.GetAsString: AnsiString;
2104 begin
2105 InitMemberIndex;
2106 if FMemberIndex >= 0 then
2107 Result := FOwner.Member[FMemberIndex].Name
2108 else
2109 Result := '';
2110 end;
2111
GetMemberCountnull2112 function TFpDwarfValueEnum.GetMemberCount: Integer;
2113 begin
2114 InitMemberIndex;
2115 if FMemberIndex < 0 then
2116 Result := 0
2117 else
2118 Result := 1;
2119 end;
2120
GetMembernull2121 function TFpDwarfValueEnum.GetMember(AIndex: Int64): TFpDbgValue;
2122 begin
2123 InitMemberIndex;
2124 if (FMemberIndex >= 0) and (AIndex = 0) then
2125 Result := FOwner.Member[FMemberIndex].Value
2126 else
2127 Result := nil;
2128 end;
2129
2130 { TFpDwarfValueEnumMember }
2131
GetFieldFlagsnull2132 function TFpDwarfValueEnumMember.GetFieldFlags: TFpDbgValueFieldFlags;
2133 begin
2134 Result := inherited GetFieldFlags;
2135 Result := Result + [svfOrdinal, svfIdentifier];
2136 end;
2137
GetAsCardinalnull2138 function TFpDwarfValueEnumMember.GetAsCardinal: QWord;
2139 begin
2140 Result := FOwnerVal.OrdinalValue;
2141 end;
2142
GetAsStringnull2143 function TFpDwarfValueEnumMember.GetAsString: AnsiString;
2144 begin
2145 Result := FOwnerVal.Name;
2146 end;
2147
IsValidTypeCastnull2148 function TFpDwarfValueEnumMember.IsValidTypeCast: Boolean;
2149 begin
2150 assert(False, 'TDbgDwarfEnumMemberSymbolValue.IsValidTypeCast can not be returned for typecast');
2151 Result := False;
2152 end;
2153
2154 constructor TFpDwarfValueEnumMember.Create(AOwner: TFpDwarfSymbolValue);
2155 begin
2156 FOwnerVal := AOwner;
2157 inherited Create(nil);
2158 end;
2159
2160 { TFpDwarfValueConstNumber }
2161
2162 procedure TFpDwarfValueConstNumber.Update(AValue: QWord; ASigned: Boolean);
2163 begin
2164 Signed := ASigned;
2165 Value := AValue;
2166 end;
2167
2168 { TFpDwarfValueSet }
2169
2170 procedure TFpDwarfValueSet.InitMap;
2171 const
2172 BitCount: array[0..15] of byte = (0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4);
2173 var
2174 i, i2, v, MemIdx, Bit, Cnt: Integer;
2175
2176 t: TFpDbgSymbol;
2177 begin
2178 if (length(FMem) > 0) or (FSize <= 0) then
2179 exit;
2180 t := TypeInfo;
2181 if t = nil then exit;
2182 t := t.TypeInfo;
2183 if t = nil then exit;
2184
2185 if not MemManager.ReadSet(DataAddr, FSize, FMem) then begin
2186 FLastError := MemManager.LastError;
2187 exit; // TODO: error
2188 end;
2189
2190 Cnt := 0;
2191 for i := 0 to FSize - 1 do
2192 Cnt := Cnt + (BitCount[FMem[i] and 15]) + (BitCount[(FMem[i] div 16) and 15]);
2193 FMemberCount := Cnt;
2194
2195 if (Cnt = 0) then exit;
2196 SetLength(FMemberMap, Cnt);
2197
2198 if (t.Kind = skEnum) then begin
2199 i2 := 0;
2200 for i := 0 to t.MemberCount - 1 do
2201 begin
2202 v := t.Member[i].OrdinalValue;
2203 MemIdx := v shr 3;
2204 Bit := 1 shl (v and 7);
2205 if (FMem[MemIdx] and Bit) <> 0 then begin
2206 assert(i2 < Cnt, 'TDbgDwarfSetSymbolValue.InitMap too many members');
2207 if i2 = Cnt then break;
2208 FMemberMap[i2] := i;
2209 inc(i2);
2210 end;
2211 end;
2212
2213 if i2 < Cnt then begin
2214 FMemberCount := i2;
2215 debugln(FPDBG_DWARF_DATA_WARNINGS, ['TDbgDwarfSetSymbolValue.InitMap not enough members']);
2216 end;
2217 end
2218 else begin
2219 i2 := 0;
2220 MemIdx := 0;
2221 Bit := 1;
2222 v := t.OrdLowBound;
2223 for i := v to t.OrdHighBound do
2224 begin
2225 if (FMem[MemIdx] and Bit) <> 0 then begin
2226 assert(i2 < Cnt, 'TDbgDwarfSetSymbolValue.InitMap too many members');
2227 if i2 = Cnt then break;
2228 FMemberMap[i2] := i - v; // offset from low-bound
2229 inc(i2);
2230 end;
2231 if Bit = 128 then begin
2232 Bit := 1;
2233 inc(MemIdx);
2234 end
2235 else
2236 Bit := Bit shl 1;
2237 end;
2238
2239 if i2 < Cnt then begin
2240 FMemberCount := i2;
2241 debugln(FPDBG_DWARF_DATA_WARNINGS, ['TDbgDwarfSetSymbolValue.InitMap not enough members']);
2242 end;
2243 end;
2244
2245 end;
2246
2247 procedure TFpDwarfValueSet.Reset;
2248 begin
2249 inherited Reset;
2250 SetLength(FMem, 0);
2251 end;
2252
GetFieldFlagsnull2253 function TFpDwarfValueSet.GetFieldFlags: TFpDbgValueFieldFlags;
2254 begin
2255 Result := inherited GetFieldFlags;
2256 Result := Result + [svfMembers];
2257 if FSize <= 8 then
2258 Result := Result + [svfOrdinal];
2259 end;
2260
GetMemberCountnull2261 function TFpDwarfValueSet.GetMemberCount: Integer;
2262 begin
2263 InitMap;
2264 Result := FMemberCount;
2265 end;
2266
GetMembernull2267 function TFpDwarfValueSet.GetMember(AIndex: Int64): TFpDbgValue;
2268 var
2269 t: TFpDbgSymbol;
2270 begin
2271 Result := nil;
2272 InitMap;
2273 t := TypeInfo;
2274 if t = nil then exit;
2275 t := t.TypeInfo;
2276 if t = nil then exit;
2277 assert(t is TFpDwarfSymbolType, 'TDbgDwarfSetSymbolValue.GetMember t');
2278
2279 if t.Kind = skEnum then begin
2280 Result := t.Member[FMemberMap[AIndex]].Value;
2281 end
2282 else begin
2283 if (FNumValue = nil) or (FNumValue.RefCount > 1) then // refcount 1 by FTypedNumValue
2284 FNumValue := TFpDwarfValueConstNumber.Create(FMemberMap[AIndex] + t.OrdLowBound, t.Kind = skInteger)
2285 else
2286 begin
2287 FNumValue.Update(FMemberMap[AIndex] + t.OrdLowBound, t.Kind = skInteger);
2288 FNumValue.AddReference;
2289 end;
2290
2291 if (FTypedNumValue = nil) or (FTypedNumValue.RefCount > 1) then begin
2292 FTypedNumValue.ReleaseReference;
2293 FTypedNumValue := t.TypeCastValue(FNumValue)
2294 end
2295 else
2296 TFpDwarfValue(FTypedNumValue).SetTypeCastInfo(TFpDwarfSymbolType(t), FNumValue); // update
2297 FNumValue.ReleaseReference;
2298 Assert((FTypedNumValue <> nil) and (TFpDwarfValue(FTypedNumValue).IsValidTypeCast), 'TDbgDwarfSetSymbolValue.GetMember FTypedNumValue');
2299 Assert((FNumValue <> nil) and (FNumValue.RefCount > 0), 'TDbgDwarfSetSymbolValue.GetMember FNumValue');
2300 Result := FTypedNumValue;
2301 end;
2302 end;
2303
GetAsCardinalnull2304 function TFpDwarfValueSet.GetAsCardinal: QWord;
2305 begin
2306 Result := 0;
2307 if (FSize <= SizeOf(Result)) and (length(FMem) > 0) then
2308 move(FMem[0], Result, FSize);
2309 end;
2310
IsValidTypeCastnull2311 function TFpDwarfValueSet.IsValidTypeCast: Boolean;
2312 var
2313 f: TFpDbgValueFieldFlags;
2314 begin
2315 Result := HasTypeCastInfo;
2316 If not Result then
2317 exit;
2318
2319 assert(FTypeCastTargetType.Kind = skSet, 'TFpDwarfValueSet.IsValidTypeCast: FTypeCastTargetType.Kind = skSet');
2320
2321 if (FTypeCastSourceValue.TypeInfo = FTypeCastTargetType)
2322 then
2323 exit; // pointer deref
2324
2325 f := FTypeCastSourceValue.FieldFlags;
2326 if (f * [svfAddress, svfSize, svfSizeOfPointer] = [svfAddress]) then
2327 exit;
2328
2329 if (f * [svfAddress, svfSize] = [svfAddress, svfSize]) and
2330 (FTypeCastSourceValue.Size = FTypeCastTargetType.Size)
2331 then
2332 exit;
2333
2334 Result := False;
2335 end;
2336
2337 destructor TFpDwarfValueSet.Destroy;
2338 begin
2339 FTypedNumValue.ReleaseReference;
2340 inherited Destroy;
2341 end;
2342
2343 { TFpDwarfValueStruct }
2344
2345 procedure TFpDwarfValueStruct.Reset;
2346 begin
2347 inherited Reset;
2348 FDataAddressDone := False;
2349 end;
2350
GetFieldFlagsnull2351 function TFpDwarfValueStruct.GetFieldFlags: TFpDbgValueFieldFlags;
2352 begin
2353 Result := inherited GetFieldFlags;
2354 Result := Result + [svfMembers];
2355
2356 //TODO: svfDataAddress should depend on (hidden) Pointer or Ref in the TypeInfo
2357 if Kind in [skClass] then begin
2358 Result := Result + [svfOrdinal, svfDataAddress, svfDataSize]; // svfDataSize
2359 if (FValueSymbol <> nil) and FValueSymbol.HasAddress then
2360 Result := Result + [svfSizeOfPointer];
2361 end
2362 else begin
2363 Result := Result + [svfSize];
2364 end;
2365 end;
2366
GetAsCardinalnull2367 function TFpDwarfValueStruct.GetAsCardinal: QWord;
2368 begin
2369 Result := QWord(LocToAddrOrNil(DataAddress));
2370 end;
2371
GetDataAddressnull2372 function TFpDwarfValueStruct.GetDataAddress: TFpDbgMemLocation;
2373 var
2374 t: TFpDbgMemLocation;
2375 begin
2376 if FValueSymbol <> nil then begin
2377 if not FDataAddressDone then begin
2378 FDataAddress := InvalidLoc;
2379 FValueSymbol.GetValueAddress(Self, t);
2380 assert(SizeOf(FDataAddress) >= AddressSize, 'TDbgDwarfStructSymbolValue.GetDataAddress');
2381 if (MemManager <> nil) then begin
2382 FDataAddress := MemManager.ReadAddress(t, AddressSize);
2383 if not IsValidLoc(FDataAddress) then
2384 FLastError := MemManager.LastError;
2385 end;
2386 FDataAddressDone := True;
2387 end;
2388 Result := FDataAddress;
2389 end
2390 else
2391 Result := inherited GetDataAddress;
2392 end;
2393
GetDataSizenull2394 function TFpDwarfValueStruct.GetDataSize: Integer;
2395 begin
2396 Assert((FValueSymbol = nil) or (FValueSymbol.TypeInfo is TFpDwarfSymbol));
2397 if (FValueSymbol <> nil) and (FValueSymbol.TypeInfo <> nil) then
2398 if FValueSymbol.TypeInfo.Kind = skClass then
2399 Result := TFpDwarfSymbol(FValueSymbol.TypeInfo).DataSize
2400 else
2401 Result := FValueSymbol.TypeInfo.Size
2402 else
2403 Result := -1;
2404 end;
2405
GetSizenull2406 function TFpDwarfValueStruct.GetSize: Integer;
2407 begin
2408 if (Kind <> skClass) and (FValueSymbol <> nil) and (FValueSymbol.TypeInfo <> nil) then
2409 Result := FValueSymbol.TypeInfo.Size
2410 else
2411 Result := -1;
2412 end;
2413
2414 { TFpDwarfValueStructTypeCast }
2415
2416 procedure TFpDwarfValueStructTypeCast.Reset;
2417 begin
2418 inherited Reset;
2419 FDataAddressDone := False;
2420 end;
2421
GetFieldFlagsnull2422 function TFpDwarfValueStructTypeCast.GetFieldFlags: TFpDbgValueFieldFlags;
2423 begin
2424 Result := inherited GetFieldFlags;
2425 Result := Result + [svfMembers];
2426 if kind = skClass then // todo detect hidden pointer
2427 Result := Result + [svfDataSize]
2428 else
2429 Result := Result + [svfSize];
2430
2431 //TODO: svfDataAddress should depend on (hidden) Pointer or Ref in the TypeInfo
2432 if Kind in [skClass] then
2433 Result := Result + [svfOrdinal, svfDataAddress, svfSizeOfPointer]; // svfDataSize
2434 end;
2435
GetKindnull2436 function TFpDwarfValueStructTypeCast.GetKind: TDbgSymbolKind;
2437 begin
2438 if HasTypeCastInfo then
2439 Result := FTypeCastTargetType.Kind
2440 else
2441 Result := inherited GetKind;
2442 end;
2443
GetAsCardinalnull2444 function TFpDwarfValueStructTypeCast.GetAsCardinal: QWord;
2445 begin
2446 Result := QWord(LocToAddrOrNil(DataAddress));
2447 end;
2448
GetSizenull2449 function TFpDwarfValueStructTypeCast.GetSize: Integer;
2450 begin
2451 if (Kind <> skClass) and (FTypeCastTargetType <> nil) then
2452 Result := FTypeCastTargetType.Size
2453 else
2454 Result := -1;
2455 end;
2456
GetDataSizenull2457 function TFpDwarfValueStructTypeCast.GetDataSize: Integer;
2458 begin
2459 Assert((FTypeCastTargetType = nil) or (FTypeCastTargetType is TFpDwarfSymbol));
2460 if FTypeCastTargetType <> nil then
2461 if FTypeCastTargetType.Kind = skClass then
2462 Result := TFpDwarfSymbol(FTypeCastTargetType).DataSize
2463 else
2464 Result := FTypeCastTargetType.Size
2465 else
2466 Result := -1;
2467 end;
2468
GetDataAddressnull2469 function TFpDwarfValueStructTypeCast.GetDataAddress: TFpDbgMemLocation;
2470 var
2471 fields: TFpDbgValueFieldFlags;
2472 t: TFpDbgMemLocation;
2473 begin
2474 if HasTypeCastInfo then begin
2475 if not FDataAddressDone then begin
2476 // TODO: wrong for records // use GetDwarfDataAddress
2477 fields := FTypeCastSourceValue.FieldFlags;
2478 if svfOrdinal in fields then
2479 FDataAddress := TargetLoc(TDbgPtr(FTypeCastSourceValue.AsCardinal))
2480 else
2481 if svfAddress in fields then begin
2482 FDataAddress := InvalidLoc;
2483 t := FTypeCastSourceValue.Address;
2484 assert(SizeOf(FDataAddress) >= AddressSize, 'TDbgDwarfStructSymbolValue.GetDataAddress');
2485 if (MemManager <> nil) then begin
2486 FDataAddress := MemManager.ReadAddress(t, AddressSize);
2487 if not IsValidLoc(FDataAddress) then
2488 FLastError := MemManager.LastError;
2489 end;
2490 end;
2491 FDataAddressDone := True;
2492 end;
2493 Result := FDataAddress;
2494 end
2495 else
2496 Result := inherited GetDataAddress;
2497 end;
2498
IsValidTypeCastnull2499 function TFpDwarfValueStructTypeCast.IsValidTypeCast: Boolean;
2500 var
2501 f: TFpDbgValueFieldFlags;
2502 begin
2503 Result := HasTypeCastInfo;
2504 if not Result then
2505 exit;
2506
2507 if FTypeCastTargetType.Kind = skClass then begin
2508 f := FTypeCastSourceValue.FieldFlags;
2509 Result := (svfOrdinal in f); // ordinal is prefered in GetDataAddress
2510 if Result then
2511 exit;
2512 Result := (svfAddress in f) and
2513 ( ( not(svfSize in f) ) or // either svfSizeOfPointer or a void type, e.g. pointer(1)^
2514 ( (svfSize in f) and (FTypeCastSourceValue.Size = AddressSize) )
2515 );
2516 end
2517 else begin
2518 f := FTypeCastSourceValue.FieldFlags;
2519 if (f * [{svfOrdinal, }svfAddress] = [svfAddress]) then begin
2520 if (f * [svfSize, svfSizeOfPointer]) = [svfSize] then
2521 Result := Result and (FTypeCastTargetType.Size = FTypeCastSourceValue.Size)
2522 else
2523 if (f * [svfSize, svfSizeOfPointer]) = [svfSizeOfPointer] then
2524 Result := Result and (FTypeCastTargetType.Size = AddressSize)
2525 else
2526 Result := (f * [svfSize, svfSizeOfPointer]) = []; // source is a void type, e.g. pointer(1)^
2527 end
2528 else
2529 Result := False;
2530 end;
2531 end;
2532
2533 destructor TFpDwarfValueStructTypeCast.Destroy;
2534 begin
2535 FreeAndNil(FMembers);
2536 inherited Destroy;
2537 end;
2538
GetMemberByNamenull2539 function TFpDwarfValueStructTypeCast.GetMemberByName(AIndex: String): TFpDbgValue;
2540 var
2541 tmp: TFpDbgSymbol;
2542 begin
2543 Result := nil;
2544 if not HasTypeCastInfo then
2545 exit;
2546
2547 tmp := FTypeCastTargetType.MemberByName[AIndex];
2548 if (tmp <> nil) then begin
2549 assert((tmp is TFpDwarfSymbolValue), 'TDbgDwarfStructTypeCastSymbolValue.GetMemberByName'+DbgSName(tmp));
2550 if FMembers = nil then
2551 FMembers := TFpDbgCircularRefCntObjList.Create;
2552 FMembers.Add(tmp);
2553
2554 Result := tmp.Value;
2555 end;
2556 SetLastMember(TFpDwarfValue(Result));
2557 end;
2558
GetMembernull2559 function TFpDwarfValueStructTypeCast.GetMember(AIndex: Int64): TFpDbgValue;
2560 var
2561 tmp: TFpDbgSymbol;
2562 begin
2563 Result := nil;
2564 if not HasTypeCastInfo then
2565 exit;
2566
2567 // TODO: Why store them all in list? They are hold by the type
2568 tmp := FTypeCastTargetType.Member[AIndex];
2569 if (tmp <> nil) then begin
2570 assert((tmp is TFpDwarfSymbolValue), 'TDbgDwarfStructTypeCastSymbolValue.GetMemberByName'+DbgSName(tmp));
2571 if FMembers = nil then
2572 FMembers := TFpDbgCircularRefCntObjList.Create;
2573 FMembers.Add(tmp);
2574
2575 Result := tmp.Value;
2576 end;
2577 SetLastMember(TFpDwarfValue(Result));
2578 end;
2579
GetMemberCountnull2580 function TFpDwarfValueStructTypeCast.GetMemberCount: Integer;
2581 var
2582 ti: TFpDbgSymbol;
2583 begin
2584 Result := 0;
2585 if not HasTypeCastInfo then
2586 exit;
2587
2588 Result := FTypeCastTargetType.MemberCount;
2589
2590 ti := FTypeCastTargetType;
2591 //TODO: cache result
2592 if ti.Kind in [skClass, skObject] then
2593 while ti.TypeInfo <> nil do begin
2594 ti := ti.TypeInfo;
2595 Result := Result + ti.MemberCount;
2596 end;
2597 end;
2598
2599 { TFpDwarfValueConstAddress }
2600
2601 procedure TFpDwarfValueConstAddress.Update(AnAddress: TFpDbgMemLocation);
2602 begin
2603 Address := AnAddress;
2604 end;
2605
2606 { TFpDwarfValueArray }
2607
GetFieldFlagsnull2608 function TFpDwarfValueArray.GetFieldFlags: TFpDbgValueFieldFlags;
2609 begin
2610 Result := inherited GetFieldFlags;
2611 Result := Result + [svfMembers];
2612 if (TypeInfo <> nil) and (sfDynArray in TypeInfo.Flags) then
2613 Result := Result + [svfOrdinal, svfDataAddress];
2614 end;
2615
GetKindnull2616 function TFpDwarfValueArray.GetKind: TDbgSymbolKind;
2617 begin
2618 Result := skArray;
2619 end;
2620
GetAsCardinalnull2621 function TFpDwarfValueArray.GetAsCardinal: QWord;
2622 begin
2623 // TODO cache
2624 if not MemManager.ReadUnsignedInt(OrdOrAddress, AddressSize, Result) then begin
2625 FLastError := MemManager.LastError;
2626 Result := 0;
2627 end;
2628 end;
2629
GetDataAddressnull2630 function TFpDwarfValueArray.GetDataAddress: TFpDbgMemLocation;
2631 begin
2632 Result := OrdOrDataAddr;
2633 end;
2634
GetMembernull2635 function TFpDwarfValueArray.GetMember(AIndex: Int64): TFpDbgValue;
2636 begin
2637 Result := GetMemberEx([AIndex]);
2638 end;
2639
GetMemberExnull2640 function TFpDwarfValueArray.GetMemberEx(const AIndex: array of Int64
2641 ): TFpDbgValue;
2642 var
2643 Addr: TFpDbgMemLocation;
2644 i: Integer;
2645 begin
2646 Result := nil;
2647 assert((FOwner is TFpDwarfSymbolTypeArray) and (FOwner.Kind = skArray));
2648
2649 Addr := TFpDwarfSymbolTypeArray(FOwner).GetMemberAddress(Self, AIndex);
2650 if not IsReadableLoc(Addr) then exit;
2651
2652 // FAddrObj.RefCount: hold by self
2653 i := 1;
2654 // FAddrObj.RefCount: hold by FLastMember (ignore only, if FLastMember is not hold by others)
2655 if (FLastMember <> nil) and (FLastMember.RefCount = 1) then
2656 i := 2;
2657 if (FAddrObj = nil) or (FAddrObj.RefCount > i) then begin
2658 FAddrObj.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FAddrObj, 'TDbgDwarfArraySymbolValue'){$ENDIF};
2659 FAddrObj := TFpDwarfValueConstAddress.Create(Addr);
2660 {$IFDEF WITH_REFCOUNT_DEBUG}FAddrObj.DbgRenameReference(@FAddrObj, 'TDbgDwarfArraySymbolValue');{$ENDIF}
2661 end
2662 else begin
2663 FAddrObj.Update(Addr);
2664 end;
2665
2666 if (FLastMember = nil) or (FLastMember.RefCount > 1) then begin
2667 SetLastMember(TFpDwarfValue(FOwner.TypeInfo.TypeCastValue(FAddrObj)));
2668 FLastMember.ReleaseReference;
2669 end
2670 else begin
2671 TFpDwarfValue(FLastMember).SetTypeCastInfo(TFpDwarfSymbolType(FOwner.TypeInfo), FAddrObj);
2672 end;
2673
2674 Result := FLastMember;
2675 end;
2676
GetMemberCountnull2677 function TFpDwarfValueArray.GetMemberCount: Integer;
2678 var
2679 t, t2: TFpDbgSymbol;
2680 Addr: TFpDbgMemLocation;
2681 LowBound, HighBound: int64;
2682 i: Int64;
2683 begin
2684 Result := 0;
2685 t := TypeInfo;
2686 if t.MemberCount < 1 then // IndexTypeCount;
2687 exit;
2688 t2 := t.Member[0]; // IndexType[0];
2689 if not ((t2 is TFpDwarfSymbolType) and (TFpDwarfSymbolType(t2).GetValueBounds(self, LowBound, HighBound))) and
2690 not t2.HasBounds then begin
2691 if (sfDynArray in t.Flags) and (AsCardinal <> 0) and
2692 GetDwarfDataAddress(Addr, TFpDwarfSymbolType(FOwner))
2693 then begin
2694 if not (IsReadableMem(Addr) and (LocToAddr(Addr) > AddressSize)) then
2695 exit;
2696 Addr.Address := Addr.Address - AddressSize;
2697 if MemManager.ReadSignedInt(Addr, AddressSize, i) then begin
2698 Result := Integer(i)+1;
2699 exit;
2700 end
2701 else
2702 FLastError := MemManager.LastError;
2703 end;
2704 exit;
2705 end;
2706 if t2.HasBounds then begin
2707 LowBound := t2.OrdLowBound;
2708 HighBound := t2.OrdHighBound;
2709 if HighBound < LowBound then
2710 exit(0); // empty array // TODO: error
2711 // TODO: XXXXX Dynamic max limit
2712 {$PUSH}{$Q-}
2713 if QWord(HighBound - LowBound) > 3000 then
2714 HighBound := LowBound + 3000;
2715 Result := Integer(HighBound - LowBound + 1);
2716 {$POP}
2717 end;
2718 end;
2719
GetMemberCountExnull2720 function TFpDwarfValueArray.GetMemberCountEx(const AIndex: array of Int64
2721 ): Integer;
2722 var
2723 t: TFpDbgSymbol;
2724 begin
2725 Result := 0;
2726 t := TypeInfo;
2727 if length(AIndex) >= t.MemberCount then
2728 exit;
2729 t := t.Member[length(AIndex)];
2730 if not t.HasBounds then
2731 exit;
2732 Result := t.OrdHighBound - t.OrdLowBound + 1;
2733 end;
2734
GetIndexTypenull2735 function TFpDwarfValueArray.GetIndexType(AIndex: Integer): TFpDbgSymbol;
2736 begin
2737 Result := TypeInfo.Member[AIndex];
2738 end;
2739
GetIndexTypeCountnull2740 function TFpDwarfValueArray.GetIndexTypeCount: Integer;
2741 begin
2742 Result := TypeInfo.MemberCount;
2743 end;
2744
IsValidTypeCastnull2745 function TFpDwarfValueArray.IsValidTypeCast: Boolean;
2746 var
2747 f: TFpDbgValueFieldFlags;
2748 begin
2749 Result := HasTypeCastInfo;
2750 If not Result then
2751 exit;
2752
2753 assert(FTypeCastTargetType.Kind = skArray, 'TFpDwarfValueArray.IsValidTypeCast: FTypeCastTargetType.Kind = skArray');
2754 //TODO: shortcut, if FTypeCastTargetType = FTypeCastSourceValue.TypeInfo ?
2755
2756 f := FTypeCastSourceValue.FieldFlags;
2757 if (f * [svfAddress, svfSize, svfSizeOfPointer] = [svfAddress]) then
2758 exit;
2759
2760 if sfDynArray in FTypeCastTargetType.Flags then begin
2761 // dyn array
2762 if (svfOrdinal in f)then
2763 exit;
2764 if (f * [svfAddress, svfSize] = [svfAddress, svfSize]) and
2765 (FTypeCastSourceValue.Size = FOwner.CompilationUnit.AddressSize)
2766 then
2767 exit;
2768 if (f * [svfAddress, svfSizeOfPointer] = [svfAddress, svfSizeOfPointer]) then
2769 exit;
2770 end
2771 else begin
2772 // stat array
2773 if (f * [svfAddress, svfSize] = [svfAddress, svfSize]) and
2774 (FTypeCastSourceValue.Size = FTypeCastTargetType.Size)
2775 then
2776 exit;
2777 end;
2778 Result := False;
2779 end;
2780
2781 destructor TFpDwarfValueArray.Destroy;
2782 begin
2783 FAddrObj.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FAddrObj, 'TDbgDwarfArraySymbolValue'){$ENDIF};
2784 inherited Destroy;
2785 end;
2786
2787 { TDbgDwarfIdentifier }
2788
GetNestedTypeInfonull2789 function TFpDwarfSymbol.GetNestedTypeInfo: TFpDwarfSymbolType;
2790 begin
2791 // TODO DW_AT_start_scope;
2792 Result := FNestedTypeInfo;
2793 if (Result <> nil) or (didtTypeRead in FDwarfReadFlags) then
2794 exit;
2795
2796 include(FDwarfReadFlags, didtTypeRead);
2797 FNestedTypeInfo := DoGetNestedTypeInfo;
2798 Result := FNestedTypeInfo;
2799 end;
2800
2801 procedure TFpDwarfSymbol.SetParentTypeInfo(AValue: TFpDwarfSymbol);
2802 begin
2803 if FParentTypeInfo = AValue then exit;
2804
2805 if (FParentTypeInfo <> nil) and CircleBackRefsActive then
2806 FParentTypeInfo.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FParentTypeInfo, 'FParentTypeInfo'){$ENDIF};
2807
2808 FParentTypeInfo := AValue;
2809
2810 if (FParentTypeInfo <> nil) and CircleBackRefsActive then
2811 FParentTypeInfo.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FParentTypeInfo, 'FParentTypeInfo'){$ENDIF};
2812 end;
2813
2814 procedure TFpDwarfSymbol.DoReferenceAdded;
2815 begin
2816 inherited DoReferenceAdded;
2817 DoPlainReferenceAdded;
2818 end;
2819
2820 procedure TFpDwarfSymbol.DoReferenceReleased;
2821 begin
2822 inherited DoReferenceReleased;
2823 DoPlainReferenceReleased;
2824 end;
2825
2826 procedure TFpDwarfSymbol.CircleBackRefActiveChanged(ANewActive: Boolean);
2827 begin
2828 if (FParentTypeInfo = nil) then
2829 exit;
2830 if ANewActive then
2831 FParentTypeInfo.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FParentTypeInfo, 'FParentTypeInfo'){$ENDIF}
2832 else
2833 FParentTypeInfo.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FParentTypeInfo, 'FParentTypeInfo'){$ENDIF};
2834 end;
2835
DoGetNestedTypeInfonull2836 function TFpDwarfSymbol.DoGetNestedTypeInfo: TFpDwarfSymbolType;
2837 var
2838 FwdInfoPtr: Pointer;
2839 FwdCompUint: TDwarfCompilationUnit;
2840 InfoEntry: TDwarfInformationEntry;
2841 begin // Do not access anything that may need forwardSymbol
2842 if InformationEntry.ReadReference(DW_AT_type, FwdInfoPtr, FwdCompUint) then begin
2843 InfoEntry := TDwarfInformationEntry.Create(FwdCompUint, FwdInfoPtr);
2844 Result := TFpDwarfSymbolType.CreateTypeSubClass('', InfoEntry);
2845 ReleaseRefAndNil(InfoEntry);
2846 end
2847 else
2848 Result := nil;
2849 end;
2850
ReadMemberVisibilitynull2851 function TFpDwarfSymbol.ReadMemberVisibility(out
2852 AMemberVisibility: TDbgSymbolMemberVisibility): Boolean;
2853 var
2854 Val: Integer;
2855 begin
2856 Result := InformationEntry.ReadValue(DW_AT_external, Val);
2857 if Result and (Val <> 0) then begin
2858 AMemberVisibility := svPublic;
2859 exit;
2860 end;
2861
2862 Result := InformationEntry.ReadValue(DW_AT_accessibility, Val);
2863 if not Result then exit;
2864 case Val of
2865 DW_ACCESS_private: AMemberVisibility := svPrivate;
2866 DW_ACCESS_protected: AMemberVisibility := svProtected;
2867 DW_ACCESS_public: AMemberVisibility := svPublic;
2868 else AMemberVisibility := svPrivate;
2869 end;
2870 end;
2871
IsArtificialnull2872 function TFpDwarfSymbol.IsArtificial: Boolean;
2873 begin
2874 if not(didtArtificialRead in FDwarfReadFlags) then begin
2875 if InformationEntry.IsArtificial then
2876 Include(FDwarfReadFlags, didtIsArtifical);
2877 Include(FDwarfReadFlags, didtArtificialRead);
2878 end;
2879 Result := didtIsArtifical in FDwarfReadFlags;
2880 end;
2881
2882 procedure TFpDwarfSymbol.NameNeeded;
2883 var
2884 AName: String;
2885 begin
2886 if InformationEntry.ReadName(AName) then
2887 SetName(AName)
2888 else
2889 inherited NameNeeded;
2890 end;
2891
2892 procedure TFpDwarfSymbol.TypeInfoNeeded;
2893 begin
2894 SetTypeInfo(NestedTypeInfo);
2895 end;
2896
DataSizenull2897 function TFpDwarfSymbol.DataSize: Integer;
2898 var
2899 t: TFpDwarfSymbolType;
2900 begin
2901 t := NestedTypeInfo;
2902 if t <> nil then
2903 Result := t.DataSize
2904 else
2905 Result := 0;
2906 end;
2907
InitLocationParsernull2908 function TFpDwarfSymbol.InitLocationParser(const ALocationParser: TDwarfLocationExpression;
2909 AnInitLocParserData: PInitLocParserData): Boolean;
2910 begin
2911 if (AnInitLocParserData <> nil) and IsValidLoc(AnInitLocParserData^.ObjectDataAddress)
2912 then begin
2913 if AnInitLocParserData^.ObjectDataAddrPush then begin
2914 debugln(FPDBG_DWARF_VERBOSE, ['TFpDwarfSymbol.InitLocationParser Push=', dbgs(AnInitLocParserData^.ObjectDataAddress)]);
2915 ALocationParser.Push(AnInitLocParserData^.ObjectDataAddress, lseValue);
2916 end
2917 else begin
2918 debugln(FPDBG_DWARF_VERBOSE, ['TFpDwarfSymbol.InitLocationParser CurrentObjectAddress=', dbgs(AnInitLocParserData^.ObjectDataAddress)]);
2919 ALocationParser.CurrentObjectAddress := AnInitLocParserData^.ObjectDataAddress;
2920 end;
2921 end;
2922
2923 Result := True;
2924 end;
2925
LocationFromTagnull2926 function TFpDwarfSymbol.LocationFromTag(ATag: Cardinal; AValueObj: TFpDwarfValue;
2927 var AnAddress: TFpDbgMemLocation; AnInitLocParserData: PInitLocParserData;
2928 AnInformationEntry: TDwarfInformationEntry; ASucessOnMissingTag: Boolean): Boolean;
2929 var
2930 Val: TByteDynArray;
2931 LocationParser: TDwarfLocationExpression;
2932 begin
2933 //debugln(['TDbgDwarfIdentifier.LocationFromTag', ClassName, ' ',Name, ' ', DwarfAttributeToString(ATag)]);
2934
2935 Result := False;
2936 if AnInformationEntry = nil then
2937 AnInformationEntry := InformationEntry;
2938
2939 //TODO: avoid copying data
2940 // DW_AT_data_member_location in members [ block or const]
2941 // DW_AT_location [block or reference] todo: const
2942 if not AnInformationEntry.ReadValue(ATag, Val) then begin
2943 (* if ASucessOnMissingTag = true AND tag does not exist
2944 then AnAddress will NOT be modified
2945 this can be used for DW_AT_data_member_location, if it does not exist members are on input location
2946 TODO: review - better use temp var in caller
2947 *)
2948 Result := ASucessOnMissingTag;
2949 if not Result then
2950 AnAddress := InvalidLoc;
2951 if not Result then
2952 DebugLn(['LocationFromTag: failed to read DW_AT_location / ASucessOnMissingTag=', dbgs(ASucessOnMissingTag)]);
2953 exit;
2954 end;
2955
2956 AnAddress := InvalidLoc;
2957 if Length(Val) = 0 then begin
2958 DebugLn('LocationFromTag: Warning DW_AT_location empty');
2959 //exit;
2960 end;
2961
2962 LocationParser := TDwarfLocationExpression.Create(@Val[0], Length(Val), CompilationUnit,
2963 AValueObj.MemManager, AValueObj.Context);
2964 InitLocationParser(LocationParser, AnInitLocParserData);
2965 LocationParser.Evaluate;
2966
2967 if IsError(LocationParser.LastError) then
2968 SetLastError(LocationParser.LastError);
2969
2970 if LocationParser.ResultKind in [lseValue] then begin
2971 AnAddress := TargetLoc(LocationParser.ResultData);
2972 if ATag=DW_AT_location then
2973 AnAddress.Address :=CompilationUnit.MapAddressToNewValue(AnAddress.Address);
2974 Result := True;
2975 end
2976 else
2977 if LocationParser.ResultKind in [lseRegister] then begin
2978 AnAddress := ConstLoc(LocationParser.ResultData);
2979 Result := True;
2980 end
2981 else
2982 debugln(['TDbgDwarfIdentifier.LocationFromTag FAILED']); // TODO
2983
2984 LocationParser.Free;
2985 end;
2986
GetDataAddressnull2987 function TFpDwarfSymbol.GetDataAddress(AValueObj: TFpDwarfValue;
2988 var AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType;
2989 ATargetCacheIndex: Integer): Boolean;
2990 var
2991 ti: TFpDwarfSymbolType;
2992 InitLocParserData: TInitLocParserData;
2993 begin
2994 InitLocParserData.ObjectDataAddress := AnAddress;
2995 InitLocParserData.ObjectDataAddrPush := False;
2996 Result := LocationFromTag(DW_AT_data_location, AValueObj, AnAddress, @InitLocParserData, nil, True);
2997 if not Result then
2998 exit;
2999
3000
3001 if ATargetType = Self then begin
3002 Result := True;
3003 exit;
3004 end;
3005
3006
3007 //TODO: Handle AValueObj.DataAddressCache[ATargetCacheIndex];
3008 Result := GetDataAddressNext(AValueObj, AnAddress, ATargetType, ATargetCacheIndex);
3009 if not Result then
3010 exit;
3011
3012 ti := NestedTypeInfo;
3013 if ti <> nil then
3014 Result := ti.GetDataAddress(AValueObj, AnAddress, ATargetType, ATargetCacheIndex+1)
3015 else
3016 Result := ATargetType = nil; // end of type chain
3017 end;
3018
GetDataAddressNextnull3019 function TFpDwarfSymbol.GetDataAddressNext(AValueObj: TFpDwarfValue;
3020 var AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType;
3021 ATargetCacheIndex: Integer): Boolean;
3022 begin
3023 Result := True;
3024 end;
3025
HasAddressnull3026 function TFpDwarfSymbol.HasAddress: Boolean;
3027 begin
3028 Result := False;
3029 end;
3030
3031 procedure TFpDwarfSymbol.Init;
3032 begin
3033 //
3034 end;
3035
3036 class function TFpDwarfSymbol.CreateSubClass(AName: String;
3037 AnInformationEntry: TDwarfInformationEntry): TFpDwarfSymbol;
3038 var
3039 c: TDbgDwarfSymbolBaseClass;
3040 begin
3041 c := AnInformationEntry.CompUnit.DwarfSymbolClassMap.GetDwarfSymbolClass(AnInformationEntry.AbbrevTag);
3042 Result := TFpDwarfSymbol(c.Create(AName, AnInformationEntry));
3043 end;
3044
3045 destructor TFpDwarfSymbol.Destroy;
3046 begin
3047 inherited Destroy;
3048 ReleaseRefAndNil(FNestedTypeInfo);
3049 Assert(not CircleBackRefsActive, 'CircleBackRefsActive can not be is destructor');
3050 // FParentTypeInfo := nil
3051 end;
3052
StartScopenull3053 function TFpDwarfSymbol.StartScope: TDbgPtr;
3054 begin
3055 if not InformationEntry.ReadStartScope(Result) then
3056 Result := 0;
3057 end;
3058
3059 { TFpDwarfSymbolValue }
3060
GetValueAddressnull3061 function TFpDwarfSymbolValue.GetValueAddress(AValueObj: TFpDwarfValue; out
3062 AnAddress: TFpDbgMemLocation): Boolean;
3063 begin
3064 Result := False;
3065 end;
3066
GetValueDataAddressnull3067 function TFpDwarfSymbolValue.GetValueDataAddress(AValueObj: TFpDwarfValue; out
3068 AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType): Boolean;
3069 begin
3070 Result := TypeInfo <> nil;
3071 if not Result then
3072 exit;
3073
3074 Assert((TypeInfo is TFpDwarfSymbol) and (TypeInfo.SymbolType = stType), 'TFpDwarfSymbolValue.GetDataAddress');
3075 Result := GetValueAddress(AValueObj, AnAddress);
3076 Result := Result and IsReadableLoc(AnAddress);
3077 if Result then begin
3078 Result := TFpDwarfSymbolType(TypeInfo).GetDataAddress(AValueObj, AnAddress, ATargetType, 1);
3079 if not Result then SetLastError(TypeInfo.LastError);
3080 end;
3081 end;
3082
3083 procedure TFpDwarfSymbolValue.KindNeeded;
3084 var
3085 t: TFpDbgSymbol;
3086 begin
3087 t := TypeInfo;
3088 if t = nil then
3089 inherited KindNeeded
3090 else
3091 SetKind(t.Kind);
3092 end;
3093
3094 procedure TFpDwarfSymbolValue.MemberVisibilityNeeded;
3095 var
3096 Val: TDbgSymbolMemberVisibility;
3097 begin
3098 if ReadMemberVisibility(Val) then
3099 SetMemberVisibility(Val)
3100 else
3101 if TypeInfo <> nil then
3102 SetMemberVisibility(TypeInfo.MemberVisibility)
3103 else
3104 inherited MemberVisibilityNeeded;
3105 end;
3106
GetMembernull3107 function TFpDwarfSymbolValue.GetMember(AIndex: Int64): TFpDbgSymbol;
3108 var
3109 ti: TFpDbgSymbol;
3110 k: TDbgSymbolKind;
3111 begin
3112 ti := TypeInfo;
3113 if ti = nil then begin
3114 Result := inherited GetMember(AIndex);
3115 exit;
3116 end;
3117
3118 k := ti.Kind;
3119 // while holding result, until refcount added, do not call any function
3120 Result := ti.Member[AIndex];
3121 assert((Result = nil) or (Result is TFpDwarfSymbolValue), 'TFpDwarfSymbolValue.GetMember is Value');
3122
3123 if (k in [skClass, skObject, skRecord {, skArray}]) and
3124 (Result <> nil) and (Result is TFpDwarfSymbolValue)
3125 then begin
3126 if FMembers = nil then
3127 FMembers := TFpDbgCircularRefCntObjList.Create;
3128 FMembers.Add(Result); //TODO: last member only?
3129 end;
3130 end;
3131
GetMemberByNamenull3132 function TFpDwarfSymbolValue.GetMemberByName(AIndex: String): TFpDbgSymbol;
3133 var
3134 ti: TFpDbgSymbol;
3135 k: TDbgSymbolKind;
3136 begin
3137 ti := TypeInfo;
3138 if ti = nil then begin
3139 Result := inherited GetMemberByName(AIndex);
3140 exit;
3141 end;
3142
3143 k := ti.Kind;
3144
3145 // while holding result, until refcount added, do not call any function
3146 Result := ti.MemberByName[AIndex];
3147 assert((Result = nil) or (Result is TFpDwarfSymbolValue), 'TFpDwarfSymbolValue.GetMember is Value');
3148
3149 if (k in [skClass, skObject, skRecord {, skArray}]) and
3150 (Result <> nil) and (Result is TFpDwarfSymbolValue)
3151 then begin
3152 if FMembers = nil then
3153 FMembers := TFpDbgCircularRefCntObjList.Create;
3154 FMembers.Add(Result);
3155 end;
3156 end;
3157
GetMemberCountnull3158 function TFpDwarfSymbolValue.GetMemberCount: Integer;
3159 var
3160 ti: TFpDbgSymbol;
3161 begin
3162 ti := TypeInfo;
3163 if ti <> nil then begin
3164 Result := ti.MemberCount;
3165 //TODO: cache result
3166 if ti.Kind in [skClass, skObject] then
3167 while ti.TypeInfo <> nil do begin
3168 ti := ti.TypeInfo;
3169 Result := Result + ti.MemberCount;
3170 end;
3171 end
3172 else
3173 Result := inherited GetMemberCount;
3174 end;
3175
3176 procedure TFpDwarfSymbolValue.Init;
3177 begin
3178 inherited Init;
3179 SetSymbolType(stValue);
3180 end;
3181
3182 destructor TFpDwarfSymbolValue.Destroy;
3183 begin
3184 Assert(not CircleBackRefsActive, 'CircleBackRefsActive can not be is ddestructor');
3185
3186 FreeAndNil(FMembers);
3187 if FValueObject <> nil then begin
3188 FValueObject.SetValueSymbol(nil);
3189 FValueObject.ReleaseCirclularReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValueObject, ClassName+'.FValueObject'){$ENDIF};
3190 FValueObject := nil;
3191 end;
3192 ParentTypeInfo := nil;
3193 inherited Destroy;
3194 end;
3195
3196 class function TFpDwarfSymbolValue.CreateValueSubClass(AName: String;
3197 AnInformationEntry: TDwarfInformationEntry): TFpDwarfSymbolValue;
3198 var
3199 c: TDbgDwarfSymbolBaseClass;
3200 begin
3201 c := AnInformationEntry.CompUnit.DwarfSymbolClassMap.GetDwarfSymbolClass(AnInformationEntry.AbbrevTag);
3202
3203 if c.InheritsFrom(TFpDwarfSymbolValue) then
3204 Result := TFpDwarfSymbolValueClass(c).Create(AName, AnInformationEntry)
3205 else
3206 Result := nil;
3207 end;
3208
3209 { TFpDwarfSymbolValueWithLocation }
3210
InitLocationParsernull3211 function TFpDwarfSymbolValueWithLocation.InitLocationParser(const ALocationParser: TDwarfLocationExpression;
3212 AnInitLocParserData: PInitLocParserData): Boolean;
3213 begin
3214 Result := inherited InitLocationParser(ALocationParser, AnInitLocParserData);
3215 ALocationParser.OnFrameBaseNeeded := @FrameBaseNeeded;
3216 end;
3217
3218 procedure TFpDwarfSymbolValueWithLocation.FrameBaseNeeded(ASender: TObject);
3219 var
3220 p: TFpDwarfSymbol;
3221 fb: TDBGPtr;
3222 begin
3223 debugln(FPDBG_DWARF_SEARCH, ['TFpDwarfSymbolValueVariable.FrameBaseNeeded ']);
3224 p := ParentTypeInfo;
3225 // TODO: what if parent is declaration?
3226 if (p <> nil) and (p is TFpDwarfSymbolValueProc) then begin
3227 fb := TFpDwarfSymbolValueProc(p).GetFrameBase(ASender as TDwarfLocationExpression);
3228 (ASender as TDwarfLocationExpression).FrameBase := fb;
3229 if fb = 0 then begin
3230 debugln(FPDBG_DWARF_ERRORS, ['DWARF ERROR in TFpDwarfSymbolValueWithLocation.FrameBaseNeeded result is 0']);
3231 end;
3232 exit;
3233 end;
3234
3235 {$warning TODO}
3236 //else
3237 //if OwnerTypeInfo <> nil then
3238 // OwnerTypeInfo.fr;
3239 // TODO: check owner
3240 debugln(FPDBG_DWARF_ERRORS, ['DWARF ERROR in TFpDwarfSymbolValueWithLocation.FrameBaseNeeded no parent type info']);
3241 (ASender as TDwarfLocationExpression).FrameBase := 0;
3242 end;
3243
GetValueObjectnull3244 function TFpDwarfSymbolValueWithLocation.GetValueObject: TFpDbgValue;
3245 var
3246 ti: TFpDbgSymbol;
3247 begin
3248 Result := FValueObject;
3249 if Result <> nil then exit;
3250
3251 ti := TypeInfo;
3252 if (ti = nil) or not (ti.SymbolType = stType) then exit;
3253
3254 FValueObject := TFpDwarfSymbolType(ti).GetTypedValueObject(False);
3255 if FValueObject <> nil then begin
3256 {$IFDEF WITH_REFCOUNT_DEBUG}FValueObject.DbgRenameReference(@FValueObject, ClassName+'.FValueObject');{$ENDIF}
3257 FValueObject.MakePlainRefToCirclular;
3258 FValueObject.SetValueSymbol(self);
3259 end;
3260
3261 Result := FValueObject;
3262 end;
3263
3264 { TFpDwarfSymbolType }
3265
3266 procedure TFpDwarfSymbolType.Init;
3267 begin
3268 inherited Init;
3269 SetSymbolType(stType);
3270 end;
3271
3272 procedure TFpDwarfSymbolType.MemberVisibilityNeeded;
3273 var
3274 Val: TDbgSymbolMemberVisibility;
3275 begin
3276 if ReadMemberVisibility(Val) then
3277 SetMemberVisibility(Val)
3278 else
3279 inherited MemberVisibilityNeeded;
3280 end;
3281
3282 procedure TFpDwarfSymbolType.SizeNeeded;
3283 var
3284 ByteSize: Integer;
3285 begin
3286 if InformationEntry.ReadValue(DW_AT_byte_size, ByteSize) then
3287 SetSize(ByteSize)
3288 else
3289 inherited SizeNeeded;
3290 end;
3291
GetTypedValueObjectnull3292 function TFpDwarfSymbolType.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
3293 begin
3294 Result := TFpDwarfValueUnknown.Create(Self);
3295 end;
3296
GetValueBoundsnull3297 function TFpDwarfSymbolType.GetValueBounds(AValueObj: TFpDwarfValue; out ALowBound,
3298 AHighBound: Int64): Boolean;
3299 begin
3300 Result := HasBounds;
3301 ALowBound := OrdLowBound;
3302 AHighBound := OrdHighBound;
3303 end;
3304
3305 procedure TFpDwarfSymbolType.ResetValueBounds;
3306 var
3307 ti: TFpDwarfSymbolType;
3308 begin
3309 ti := NestedTypeInfo;
3310 if (ti <> nil) then
3311 ti.ResetValueBounds;
3312 end;
3313
3314 class function TFpDwarfSymbolType.CreateTypeSubClass(AName: String;
3315 AnInformationEntry: TDwarfInformationEntry): TFpDwarfSymbolType;
3316 var
3317 c: TDbgDwarfSymbolBaseClass;
3318 begin
3319 c := AnInformationEntry.CompUnit.DwarfSymbolClassMap.GetDwarfSymbolClass(AnInformationEntry.AbbrevTag);
3320
3321 if c.InheritsFrom(TFpDwarfSymbolType) then
3322 Result := TFpDwarfSymbolTypeClass(c).Create(AName, AnInformationEntry)
3323 else
3324 Result := nil;
3325 end;
3326
TypeCastValuenull3327 function TFpDwarfSymbolType.TypeCastValue(AValue: TFpDbgValue): TFpDbgValue;
3328 begin
3329 Result := GetTypedValueObject(True);
3330 If Result = nil then
3331 exit;
3332 assert(Result is TFpDwarfValue);
3333 if not TFpDwarfValue(Result).SetTypeCastInfo(self, AValue) then
3334 ReleaseRefAndNil(Result);
3335 end;
3336
3337 { TDbgDwarfBaseTypeIdentifier }
3338
3339 procedure TFpDwarfSymbolTypeBasic.KindNeeded;
3340 var
3341 Encoding, ByteSize: Integer;
3342 begin
3343 if not InformationEntry.ReadValue(DW_AT_encoding, Encoding) then begin
3344 DebugLn(FPDBG_DWARF_WARNINGS, ['TFpDwarfSymbolTypeBasic.KindNeeded: Failed reading encoding for ', DwarfTagToString(InformationEntry.AbbrevTag)]);
3345 inherited KindNeeded;
3346 exit;
3347 end;
3348
3349 if InformationEntry.ReadValue(DW_AT_byte_size, ByteSize) then
3350 SetSize(ByteSize);
3351
3352 case Encoding of
3353 DW_ATE_address : SetKind(skPointer);
3354 DW_ATE_boolean: SetKind(skBoolean);
3355 //DW_ATE_complex_float:
3356 DW_ATE_float: SetKind(skFloat);
3357 DW_ATE_signed: SetKind(skInteger);
3358 DW_ATE_signed_char: SetKind(skChar);
3359 DW_ATE_unsigned: SetKind(skCardinal);
3360 DW_ATE_unsigned_char: SetKind(skChar);
3361 DW_ATE_numeric_string:SetKind(skChar); // temporary for widestring
3362 else
3363 begin
3364 DebugLn(FPDBG_DWARF_WARNINGS, ['TFpDwarfSymbolTypeBasic.KindNeeded: Unknown encoding ', DwarfBaseTypeEncodingToString(Encoding), ' for ', DwarfTagToString(InformationEntry.AbbrevTag)]);
3365 inherited KindNeeded;
3366 end;
3367 end;
3368 end;
3369
3370 procedure TFpDwarfSymbolTypeBasic.TypeInfoNeeded;
3371 begin
3372 SetTypeInfo(nil);
3373 end;
3374
GetTypedValueObjectnull3375 function TFpDwarfSymbolTypeBasic.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
3376 begin
3377 case Kind of
3378 skPointer: Result := TFpDwarfValuePointer.Create(Self, Size);
3379 skInteger: Result := TFpDwarfValueInteger.Create(Self, Size);
3380 skCardinal: Result := TFpDwarfValueCardinal.Create(Self, Size);
3381 skBoolean: Result := TFpDwarfValueBoolean.Create(Self, Size);
3382 skChar: Result := TFpDwarfValueChar.Create(Self, Size);
3383 skFloat: Result := TFpDwarfValueFloat.Create(Self, Size);
3384 end;
3385 end;
3386
GetHasBoundsnull3387 function TFpDwarfSymbolTypeBasic.GetHasBounds: Boolean;
3388 begin
3389 Result := (kind = skInteger) or (kind = skCardinal);
3390 end;
3391
GetOrdHighBoundnull3392 function TFpDwarfSymbolTypeBasic.GetOrdHighBound: Int64;
3393 begin
3394 case Kind of
3395 skInteger: Result := int64( high(int64) shr (64 - Min(Size, 8) * 8));
3396 skCardinal: Result := int64( high(qword) shr (64 - Min(Size, 8) * 8));
3397 else
3398 Result := inherited GetOrdHighBound;
3399 end;
3400 end;
3401
GetOrdLowBoundnull3402 function TFpDwarfSymbolTypeBasic.GetOrdLowBound: Int64;
3403 begin
3404 case Kind of
3405 skInteger: Result := -(int64( high(int64) shr (64 - Min(Size, 8) * 8)))-1;
3406 skCardinal: Result := 0;
3407 else
3408 Result := inherited GetOrdHighBound;
3409 end;
3410 end;
3411
3412 { TFpDwarfSymbolTypeModifier }
3413
3414 procedure TFpDwarfSymbolTypeModifier.TypeInfoNeeded;
3415 var
3416 p: TFpDwarfSymbolType;
3417 begin
3418 p := NestedTypeInfo;
3419 if p <> nil then
3420 SetTypeInfo(p.TypeInfo)
3421 else
3422 SetTypeInfo(nil);
3423 end;
3424
3425 procedure TFpDwarfSymbolTypeModifier.ForwardToSymbolNeeded;
3426 begin
3427 SetForwardToSymbol(NestedTypeInfo)
3428 end;
3429
GetTypedValueObjectnull3430 function TFpDwarfSymbolTypeModifier.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
3431 var
3432 ti: TFpDwarfSymbolType;
3433 begin
3434 ti := NestedTypeInfo;
3435 if ti <> nil then
3436 Result := ti.GetTypedValueObject(ATypeCast)
3437 else
3438 Result := inherited;
3439 end;
3440
3441 { TFpDwarfSymbolTypeRef }
3442
GetFlagsnull3443 function TFpDwarfSymbolTypeRef.GetFlags: TDbgSymbolFlags;
3444 begin
3445 Result := (inherited GetFlags) + [sfInternalRef];
3446 end;
3447
GetDataAddressNextnull3448 function TFpDwarfSymbolTypeRef.GetDataAddressNext(AValueObj: TFpDwarfValue;
3449 var AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType;
3450 ATargetCacheIndex: Integer): Boolean;
3451 var
3452 t: TFpDbgMemLocation;
3453 begin
3454 t := AValueObj.DataAddressCache[ATargetCacheIndex];
3455 if IsInitializedLoc(t) then begin
3456 AnAddress := t;
3457 end
3458 else begin
3459 Result := AValueObj.MemManager <> nil;
3460 if not Result then
3461 exit;
3462 AnAddress := AValueObj.MemManager.ReadAddress(AnAddress, CompilationUnit.AddressSize);
3463 AValueObj.DataAddressCache[ATargetCacheIndex] := AnAddress;
3464 end;
3465 Result := IsValidLoc(AnAddress);
3466
3467 if Result then
3468 Result := inherited GetDataAddressNext(AValueObj, AnAddress, ATargetType, ATargetCacheIndex)
3469 else
3470 if IsError(AValueObj.MemManager.LastError) then
3471 SetLastError(AValueObj.MemManager.LastError);
3472 // Todo: other error
3473 end;
3474
3475 { TFpDwarfSymbolTypeDeclaration }
3476
DoGetNestedTypeInfonull3477 function TFpDwarfSymbolTypeDeclaration.DoGetNestedTypeInfo: TFpDwarfSymbolType;
3478 var
3479 ti: TFpDwarfSymbolType;
3480 ti2: TFpDbgSymbol;
3481 begin
3482 Result := inherited DoGetNestedTypeInfo;
3483
3484 // Is internal class pointer?
3485 // Do not trigged any cached property of the pointer
3486 if (Result = nil) then
3487 exit;
3488
3489 ti := Result;
3490 if (ti is TFpDwarfSymbolTypeModifier) then begin
3491 ti := TFpDwarfSymbolType(ti.TypeInfo);
3492 if (Result = nil) then
3493 exit;
3494 end;
3495 if not (ti is TFpDwarfSymbolTypePointer) then
3496 exit;
3497
3498 ti2 := ti.NestedTypeInfo;
3499 // only if it is NOT a declaration
3500 if (ti2 <> nil) and (ti2 is TFpDwarfSymbolTypeStructure) then begin
3501 TFpDwarfSymbolTypePointer(ti).IsInternalPointer := True;
3502 // TODO: Flag the structure as class (save teme in KindNeeded)
3503 end;
3504 end;
3505
3506 { TFpDwarfSymbolTypeSubRange }
3507
3508 procedure TFpDwarfSymbolTypeSubRange.InitEnumIdx;
3509 var
3510 t: TFpDwarfSymbolType;
3511 i: Integer;
3512 h, l: Int64;
3513 begin
3514 if FEnumIdxValid then
3515 exit;
3516 FEnumIdxValid := True;
3517
3518 t := NestedTypeInfo;
3519 i := t.MemberCount - 1;
3520 h := OrdHighBound;
3521 l := OrdLowBound;
3522
3523 while (i >= 0) and (t.Member[i].OrdinalValue > h) do
3524 dec(i);
3525 FHighEnumIdx := i;
3526
3527 while (i >= 0) and (t.Member[i].OrdinalValue >= l) do
3528 dec(i);
3529 FLowEnumIdx := i + 1;
3530 end;
3531
3532 procedure TFpDwarfSymbolTypeSubRange.ReadBounds(AValueObj: TFpDwarfValue);
3533 var
3534 FwdInfoPtr: Pointer;
3535 FwdCompUint: TDwarfCompilationUnit;
3536 NewInfo: TDwarfInformationEntry;
3537 var
3538 AnAddress: TFpDbgMemLocation;
3539 InitLocParserData: TInitLocParserData;
3540 begin
3541 // TODO: assert(AValueObj <> nil, 'TFpDwarfSymbolTypeSubRange.ReadBounds: AValueObj <> nil');
3542 if FLowBoundState <> rfNotRead then exit;
3543
3544 // Todo: search attrib-IDX only once
3545 // Todo: LocationFromTag()
3546 if InformationEntry.ReadReference(DW_AT_lower_bound, FwdInfoPtr, FwdCompUint) then begin
3547 NewInfo := TDwarfInformationEntry.Create(FwdCompUint, FwdInfoPtr);
3548 FLowBoundValue := TFpDwarfSymbolValue.CreateValueSubClass('', NewInfo);
3549 NewInfo.ReleaseReference;
3550 if FLowBoundValue = nil then begin
3551 FLowBoundState := rfNotFound;
3552 exit;
3553 end
3554 else
3555 FLowBoundState := rfValue;
3556 end
3557 else
3558 if InformationEntry.ReadValue(DW_AT_lower_bound, FLowBoundConst) then begin
3559 FLowBoundState := rfConst;
3560 end
3561 else
3562 begin
3563 //FLowBoundConst := 0; // the default
3564 //FLowBoundState := rfConst;
3565 FLowBoundState := rfNotFound;
3566 exit; // incomplete type
3567 end;
3568
3569
3570 if InformationEntry.ReadReference(DW_AT_upper_bound, FwdInfoPtr, FwdCompUint) then begin
3571 NewInfo := TDwarfInformationEntry.Create(FwdCompUint, FwdInfoPtr);
3572 FHighBoundValue := TFpDwarfSymbolValue.CreateValueSubClass('', NewInfo);
3573 NewInfo.ReleaseReference;
3574 if FHighBoundValue = nil then begin
3575 FHighBoundState := rfNotFound;
3576 exit;
3577 end
3578 else
3579 FHighBoundState := rfValue;
3580 end
3581 else
3582 if InformationEntry.ReadValue(DW_AT_upper_bound, FHighBoundConst) then begin
3583 FHighBoundState := rfConst;
3584 end
3585 else
3586 begin
3587 if assigned(AValueObj) then
3588 InitLocParserData.ObjectDataAddress := AValueObj.Address;
3589 InitLocParserData.ObjectDataAddrPush := False;
3590 if assigned(AValueObj) and LocationFromTag(DW_AT_upper_bound, AValueObj, AnAddress, @InitLocParserData, InformationEntry) then begin
3591 FHighBoundState := rfConst;
3592 FHighBoundConst := Int64(AnAddress.Address);
3593 end
3594 else
3595 begin
3596 FHighBoundState := rfNotFound;
3597
3598 if InformationEntry.ReadReference(DW_AT_count, FwdInfoPtr, FwdCompUint) then begin
3599 NewInfo := TDwarfInformationEntry.Create(FwdCompUint, FwdInfoPtr);
3600 FCountValue := TFpDwarfSymbolValue.CreateValueSubClass('', NewInfo);
3601 NewInfo.ReleaseReference;
3602 if FCountValue = nil then begin
3603 FCountState := rfNotFound;
3604 exit;
3605 end
3606 else
3607 FCountState := rfValue;
3608 end
3609 else
3610 if InformationEntry.ReadValue(DW_AT_count, FCountConst) then begin
3611 FCountState := rfConst;
3612 end
3613 else
3614 FCountState := rfNotFound;
3615 end;
3616 end;
3617 end;
3618
DoGetNestedTypeInfonull3619 function TFpDwarfSymbolTypeSubRange.DoGetNestedTypeInfo: TFpDwarfSymbolType;
3620 begin
3621 Result := inherited DoGetNestedTypeInfo;
3622 if Result <> nil then
3623 exit;
3624
3625 if FLowBoundState = rfValue then
3626 Result := FLowBoundValue.TypeInfo as TFpDwarfSymbolType
3627 else
3628 if FHighBoundState = rfValue then
3629 Result := FHighBoundValue.TypeInfo as TFpDwarfSymbolType
3630 else
3631 if FCountState = rfValue then
3632 Result := FCountValue.TypeInfo as TFpDwarfSymbolType;
3633 end;
3634
GetHasBoundsnull3635 function TFpDwarfSymbolTypeSubRange.GetHasBounds: Boolean;
3636 begin
3637 ReadBounds(nil);
3638 // TODO: currently limited to const.
3639 // not standard, but upper may be missing?
3640 Result := (FLowBoundState in [rfConst]) and
3641 ( (FHighBoundState in [rfConst]) or
3642 (FCountState in [rfConst]) );
3643
3644 (*
3645 Result := (FLowBoundState in [rfValue, rfConst]) and
3646 ( (FHighBoundState in [rfValue, rfConst]) or
3647 (FCountState in [rfValue, rfConst]) );
3648 *)
3649 end;
3650
GetOrdHighBoundnull3651 function TFpDwarfSymbolTypeSubRange.GetOrdHighBound: Int64;
3652 begin
3653 // Todo range check off.
3654 //if FHighBoundState = rfValue then
3655 // Result := FHighBoundValue.VALUE // TODO
3656 //else
3657 if FHighBoundState = rfConst then
3658 Result := FHighBoundConst
3659 else
3660 //if FCountState = rfValue then
3661 // Result := GetOrdLowBound + FCountValue.VALUE - 1 // TODO
3662 //else
3663 if FHighBoundState = rfConst then
3664 Result := GetOrdLowBound + FCountConst - 1;
3665 end;
3666
GetOrdLowBoundnull3667 function TFpDwarfSymbolTypeSubRange.GetOrdLowBound: Int64;
3668 begin
3669 //if FLowBoundState = rfValue then
3670 // Result := FLowBoundValue.VALUE // TODO
3671 //else
3672 Result := FLowBoundConst;
3673 end;
3674
3675 procedure TFpDwarfSymbolTypeSubRange.NameNeeded;
3676 var
3677 AName: String;
3678 begin
3679 if InformationEntry.ReadName(AName) then
3680 SetName(AName)
3681 else
3682 SetName('');
3683 end;
3684
3685 procedure TFpDwarfSymbolTypeSubRange.KindNeeded;
3686 var
3687 t: TFpDbgSymbol;
3688 begin
3689 // TODO: limit to ordinal types
3690 if not HasBounds then begin // does ReadBounds;
3691 SetKind(skNone); // incomplete type
3692 end;
3693
3694 t := NestedTypeInfo;
3695 if t = nil then begin
3696 SetKind(skInteger);
3697 SetSize(CompilationUnit.AddressSize);
3698 end
3699 else
3700 SetKind(t.Kind);
3701 end;
3702
3703 procedure TFpDwarfSymbolTypeSubRange.SizeNeeded;
3704 var
3705 t: TFpDbgSymbol;
3706 begin
3707 t := NestedTypeInfo;
3708 if t = nil then begin
3709 SetKind(skInteger);
3710 SetSize(CompilationUnit.AddressSize);
3711 end
3712 else
3713 SetSize(t.Size);
3714 end;
3715
GetMembernull3716 function TFpDwarfSymbolTypeSubRange.GetMember(AIndex: Int64): TFpDbgSymbol;
3717 begin
3718 if Kind = skEnum then begin
3719 if not FEnumIdxValid then
3720 InitEnumIdx;
3721 Result := NestedTypeInfo.Member[AIndex - FLowEnumIdx];
3722 end
3723 else
3724 Result := inherited GetMember(AIndex);
3725 end;
3726
GetMemberCountnull3727 function TFpDwarfSymbolTypeSubRange.GetMemberCount: Integer;
3728 begin
3729 if Kind = skEnum then begin
3730 if not FEnumIdxValid then
3731 InitEnumIdx;
3732 Result := FHighEnumIdx - FLowEnumIdx + 1;
3733 end
3734 else
3735 Result := inherited GetMemberCount;
3736 end;
3737
GetFlagsnull3738 function TFpDwarfSymbolTypeSubRange.GetFlags: TDbgSymbolFlags;
3739 begin
3740 Result := (inherited GetFlags) + [sfSubRange];
3741 end;
3742
GetValueBoundsnull3743 function TFpDwarfSymbolTypeSubRange.GetValueBounds(AValueObj: TFpDwarfValue; out
3744 ALowBound, AHighBound: Int64): Boolean;
3745 begin
3746 ReadBounds(AValueObj);
3747 Result := inherited GetValueBounds(AValueObj, ALowBound, AHighBound);
3748 end;
3749
3750 procedure TFpDwarfSymbolTypeSubRange.ResetValueBounds;
3751 begin
3752 inherited ResetValueBounds;
3753 FLowBoundState := rfNotRead;
3754 FHighBoundState := rfNotRead;
3755 FCountState := rfNotRead;
3756 end;
3757
3758 procedure TFpDwarfSymbolTypeSubRange.Init;
3759 begin
3760 FLowBoundState := rfNotRead;
3761 FHighBoundState := rfNotRead;
3762 FCountState := rfNotRead;
3763 inherited Init;
3764 end;
3765
3766 { TFpDwarfSymbolTypePointer }
3767
IsInternalDynArrayPointernull3768 function TFpDwarfSymbolTypePointer.IsInternalDynArrayPointer: Boolean;
3769 var
3770 ti: TFpDbgSymbol;
3771 begin
3772 Result := False;
3773 ti := NestedTypeInfo; // Same as TypeInfo, but does not try to be forwarded
3774 Result := (ti <> nil) and (ti is TFpDwarfSymbolTypeArray);
3775 if Result then
3776 Result := (sfDynArray in ti.Flags);
3777 end;
3778
3779 procedure TFpDwarfSymbolTypePointer.TypeInfoNeeded;
3780 var
3781 p: TFpDwarfSymbolType;
3782 begin
3783 p := NestedTypeInfo;
3784 if IsInternalPointer and (p <> nil) then begin
3785 SetTypeInfo(p.TypeInfo);
3786 exit;
3787 end;
3788 SetTypeInfo(p);
3789 end;
3790
GetIsInternalPointernull3791 function TFpDwarfSymbolTypePointer.GetIsInternalPointer: Boolean;
3792 begin
3793 Result := FIsInternalPointer or IsInternalDynArrayPointer;
3794 end;
3795
3796 procedure TFpDwarfSymbolTypePointer.KindNeeded;
3797 var
3798 k: TDbgSymbolKind;
3799 begin
3800 if IsInternalPointer then begin
3801 k := NestedTypeInfo.Kind;
3802 if k = skObject then
3803 SetKind(skClass)
3804 else
3805 SetKind(k);
3806 end
3807 else
3808 SetKind(skPointer);
3809 end;
3810
3811 procedure TFpDwarfSymbolTypePointer.SizeNeeded;
3812 begin
3813 SetSize(CompilationUnit.AddressSize);
3814 end;
3815
3816 procedure TFpDwarfSymbolTypePointer.ForwardToSymbolNeeded;
3817 begin
3818 if IsInternalPointer then
3819 SetForwardToSymbol(NestedTypeInfo) // Same as TypeInfo, but does not try to be forwarded
3820 else
3821 SetForwardToSymbol(nil); // inherited ForwardToSymbolNeeded;
3822 end;
3823
GetDataAddressNextnull3824 function TFpDwarfSymbolTypePointer.GetDataAddressNext(AValueObj: TFpDwarfValue;
3825 var AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType;
3826 ATargetCacheIndex: Integer): Boolean;
3827 var
3828 t: TFpDbgMemLocation;
3829 begin
3830 t := AValueObj.DataAddressCache[ATargetCacheIndex];
3831 if IsInitializedLoc(t) then begin
3832 AnAddress := t;
3833 end
3834 else begin
3835 Result := AValueObj.MemManager <> nil;
3836 if not Result then
3837 exit;
3838 AnAddress := AValueObj.MemManager.ReadAddress(AnAddress, CompilationUnit.AddressSize);
3839 AValueObj.DataAddressCache[ATargetCacheIndex] := AnAddress;
3840 end;
3841 Result := IsValidLoc(AnAddress);
3842
3843 if Result then
3844 Result := inherited GetDataAddressNext(AValueObj, AnAddress, ATargetType, ATargetCacheIndex)
3845 else
3846 if IsError(AValueObj.MemManager.LastError) then
3847 SetLastError(AValueObj.MemManager.LastError);
3848 // Todo: other error
3849 end;
3850
GetTypedValueObjectnull3851 function TFpDwarfSymbolTypePointer.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
3852 begin
3853 if IsInternalPointer then
3854 Result := NestedTypeInfo.GetTypedValueObject(ATypeCast)
3855 else
3856 Result := TFpDwarfValuePointer.Create(Self, CompilationUnit.AddressSize);
3857 end;
3858
DataSizenull3859 function TFpDwarfSymbolTypePointer.DataSize: Integer;
3860 begin
3861 if Kind = skClass then
3862 Result := NestedTypeInfo.Size
3863 else
3864 Result := inherited DataSize;
3865 end;
3866
3867 { TDbgDwarfIdentifierEnumElement }
3868
3869 procedure TFpDwarfSymbolValueEnumMember.ReadOrdinalValue;
3870 begin
3871 if FOrdinalValueRead then exit;
3872 FOrdinalValueRead := True;
3873 FHasOrdinalValue := InformationEntry.ReadValue(DW_AT_const_value, FOrdinalValue);
3874 end;
3875
3876 procedure TFpDwarfSymbolValueEnumMember.KindNeeded;
3877 begin
3878 SetKind(skEnumValue);
3879 end;
3880
GetHasOrdinalValuenull3881 function TFpDwarfSymbolValueEnumMember.GetHasOrdinalValue: Boolean;
3882 begin
3883 ReadOrdinalValue;
3884 Result := FHasOrdinalValue;
3885 end;
3886
GetOrdinalValuenull3887 function TFpDwarfSymbolValueEnumMember.GetOrdinalValue: Int64;
3888 begin
3889 ReadOrdinalValue;
3890 Result := FOrdinalValue;
3891 end;
3892
3893 procedure TFpDwarfSymbolValueEnumMember.Init;
3894 begin
3895 FOrdinalValueRead := False;
3896 inherited Init;
3897 end;
3898
GetValueObjectnull3899 function TFpDwarfSymbolValueEnumMember.GetValueObject: TFpDbgValue;
3900 begin
3901 Result := FValueObject;
3902 if Result <> nil then exit;
3903
3904 FValueObject := TFpDwarfValueEnumMember.Create(Self);
3905 {$IFDEF WITH_REFCOUNT_DEBUG}FValueObject.DbgRenameReference(@FValueObject, ClassName+'.FValueObject');{$ENDIF}
3906 FValueObject.MakePlainRefToCirclular;
3907 FValueObject.SetValueSymbol(self);
3908
3909 Result := FValueObject;
3910 end;
3911
3912 { TFpDwarfSymbolTypeEnum }
3913
3914 procedure TFpDwarfSymbolTypeEnum.CreateMembers;
3915 var
3916 Info, Info2: TDwarfInformationEntry;
3917 sym: TFpDwarfSymbol;
3918 begin
3919 if FMembers <> nil then
3920 exit;
3921 FMembers := TFpDbgCircularRefCntObjList.Create;
3922 Info := InformationEntry.FirstChild;
3923 if Info = nil then exit;
3924
3925 while Info.HasValidScope do begin
3926 if (Info.AbbrevTag = DW_TAG_enumerator) then begin
3927 Info2 := Info.Clone;
3928 sym := TFpDwarfSymbol.CreateSubClass('', Info2);
3929 FMembers.Add(sym);
3930 sym.ReleaseReference;
3931 sym.ParentTypeInfo := self;
3932 Info2.ReleaseReference;
3933 end;
3934 Info.GoNext;
3935 end;
3936
3937 Info.ReleaseReference;
3938 end;
3939
GetTypedValueObjectnull3940 function TFpDwarfSymbolTypeEnum.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
3941 begin
3942 Result := TFpDwarfValueEnum.Create(Self, Size);
3943 end;
3944
3945 procedure TFpDwarfSymbolTypeEnum.KindNeeded;
3946 begin
3947 SetKind(skEnum);
3948 end;
3949
GetMembernull3950 function TFpDwarfSymbolTypeEnum.GetMember(AIndex: Int64): TFpDbgSymbol;
3951 begin
3952 CreateMembers;
3953 Result := TFpDbgSymbol(FMembers[AIndex]);
3954 end;
3955
GetMemberByNamenull3956 function TFpDwarfSymbolTypeEnum.GetMemberByName(AIndex: String): TFpDbgSymbol;
3957 var
3958 i: Integer;
3959 s, s1, s2: String;
3960 begin
3961 if AIndex = '' then
3962 s1 := UTF8UpperCase(AIndex);
3963 s2 := UTF8LowerCase(AIndex);
3964 CreateMembers;
3965 i := FMembers.Count - 1;
3966 while i >= 0 do begin
3967 Result := TFpDbgSymbol(FMembers[i]);
3968 s := Result.Name;
3969 if (s <> '') and CompareUtf8BothCase(@s1[1], @s2[1], @s[1]) then
3970 exit;
3971 dec(i);
3972 end;
3973 Result := nil;
3974 end;
3975
GetMemberCountnull3976 function TFpDwarfSymbolTypeEnum.GetMemberCount: Integer;
3977 begin
3978 CreateMembers;
3979 Result := FMembers.Count;
3980 end;
3981
GetHasBoundsnull3982 function TFpDwarfSymbolTypeEnum.GetHasBounds: Boolean;
3983 begin
3984 Result := True;
3985 end;
3986
GetOrdHighBoundnull3987 function TFpDwarfSymbolTypeEnum.GetOrdHighBound: Int64;
3988 var
3989 c: Integer;
3990 begin
3991 c := MemberCount;
3992 if c > 0 then
3993 Result := Member[c-1].OrdinalValue
3994 else
3995 Result := -1;
3996 end;
3997
GetOrdLowBoundnull3998 function TFpDwarfSymbolTypeEnum.GetOrdLowBound: Int64;
3999 var
4000 c: Integer;
4001 begin
4002 c := MemberCount;
4003 if c > 0 then
4004 Result := Member[0].OrdinalValue
4005 else
4006 Result := 0;
4007 end;
4008
4009 destructor TFpDwarfSymbolTypeEnum.Destroy;
4010 var
4011 i: Integer;
4012 begin
4013 if FMembers <> nil then
4014 for i := 0 to FMembers.Count - 1 do
4015 TFpDwarfSymbol(FMembers[i]).ParentTypeInfo := nil;
4016 FreeAndNil(FMembers);
4017 inherited Destroy;
4018 end;
4019
4020 { TFpDwarfSymbolTypeSet }
4021
4022 procedure TFpDwarfSymbolTypeSet.KindNeeded;
4023 begin
4024 SetKind(skSet);
4025 end;
4026
GetTypedValueObjectnull4027 function TFpDwarfSymbolTypeSet.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
4028 begin
4029 Result := TFpDwarfValueSet.Create(Self, Size);
4030 end;
4031
GetMemberCountnull4032 function TFpDwarfSymbolTypeSet.GetMemberCount: Integer;
4033 begin
4034 if TypeInfo.Kind = skEnum then
4035 Result := TypeInfo.MemberCount
4036 else
4037 Result := inherited GetMemberCount;
4038 end;
4039
GetMembernull4040 function TFpDwarfSymbolTypeSet.GetMember(AIndex: Int64): TFpDbgSymbol;
4041 begin
4042 if TypeInfo.Kind = skEnum then
4043 Result := TypeInfo.Member[AIndex]
4044 else
4045 Result := inherited GetMember(AIndex);
4046 end;
4047
4048 { TFpDwarfSymbolValueMember }
4049
GetValueAddressnull4050 function TFpDwarfSymbolValueMember.GetValueAddress(AValueObj: TFpDwarfValue; out
4051 AnAddress: TFpDbgMemLocation): Boolean;
4052 var
4053 BaseAddr: TFpDbgMemLocation;
4054 InitLocParserData: TInitLocParserData;
4055 begin
4056 AnAddress := AValueObj.DataAddressCache[0];
4057 Result := IsValidLoc(AnAddress);
4058 if IsInitializedLoc(AnAddress) then
4059 exit;
4060
4061 if AValueObj = nil then debugln(['TFpDwarfSymbolValueMember.InitLocationParser: NO VAl Obj !!!!!!!!!!!!!!!'])
4062 else if AValueObj.StructureValue = nil then debugln(['TFpDwarfSymbolValueMember.InitLocationParser: NO STRUCT Obj !!!!!!!!!!!!!!!']);
4063
4064 if (AValueObj = nil) or (AValueObj.StructureValue = nil) or (ParentTypeInfo = nil)
4065 then begin
4066 debugln(FPDBG_DWARF_ERRORS, ['DWARF ERROR in TFpDwarfSymbolValueMember.InitLocationParser Error: ',ErrorCode(LastError),' ValueObject=', DbgSName(FValueObject)]);
4067 Result := False;
4068 if not IsError(LastError) then
4069 SetLastError(CreateError(fpErrLocationParserInit)); // TODO: error message?
4070 exit;
4071 end;
4072 Assert((ParentTypeInfo is TFpDwarfSymbol) and (ParentTypeInfo.SymbolType = stType), '');
4073 if not AValueObj.GetStructureDwarfDataAddress(BaseAddr, TFpDwarfSymbolType(ParentTypeInfo)) then begin
4074 debugln(FPDBG_DWARF_ERRORS, ['DWARF ERROR in TFpDwarfSymbolValueMember.InitLocationParser Error: ',ErrorCode(LastError),' ValueObject=', DbgSName(FValueObject)]);
4075 Result := False;
4076 if not IsError(LastError) then
4077 SetLastError(CreateError(fpErrLocationParserInit)); // TODO: error message?
4078 exit;
4079 end;
4080 //TODO: AValueObj.StructureValue.LastError
4081
4082 InitLocParserData.ObjectDataAddress := BaseAddr;
4083 InitLocParserData.ObjectDataAddrPush := True;
4084 Result := LocationFromTag(DW_AT_data_member_location, AValueObj, AnAddress, @InitLocParserData);
4085
4086 AValueObj.DataAddressCache[0] := AnAddress;
4087 end;
4088
HasAddressnull4089 function TFpDwarfSymbolValueMember.HasAddress: Boolean;
4090 begin
4091 Result := (InformationEntry.HasAttrib(DW_AT_data_member_location));
4092 end;
4093
4094 { TFpDwarfSymbolTypeStructure }
4095
GetMemberByNamenull4096 function TFpDwarfSymbolTypeStructure.GetMemberByName(AIndex: String): TFpDbgSymbol;
4097 var
4098 Ident: TDwarfInformationEntry;
4099 ti: TFpDbgSymbol;
4100 begin
4101 // Todo, maybe create all children?
4102 if FLastChildByName <> nil then begin
4103 FLastChildByName.ReleaseCirclularReference;
4104 FLastChildByName := nil;
4105 end;
4106 Result := nil;
4107
4108 Ident := InformationEntry.FindNamedChild(AIndex);
4109 if Ident <> nil then begin
4110 FLastChildByName := TFpDwarfSymbol.CreateSubClass('', Ident);
4111 FLastChildByName.MakePlainRefToCirclular;
4112 FLastChildByName.ParentTypeInfo := self;
4113 //assert is member ?
4114 ReleaseRefAndNil(Ident);
4115 Result := FLastChildByName;
4116
4117 exit;
4118 end;
4119
4120 ti := TypeInfo; // Parent
4121 if ti <> nil then
4122 Result := ti.MemberByName[AIndex];
4123 end;
4124
GetMemberCountnull4125 function TFpDwarfSymbolTypeStructure.GetMemberCount: Integer;
4126 begin
4127 CreateMembers;
4128 Result := FMembers.Count;
4129 end;
4130
GetDataAddressNextnull4131 function TFpDwarfSymbolTypeStructure.GetDataAddressNext(AValueObj: TFpDwarfValue;
4132 var AnAddress: TFpDbgMemLocation; ATargetType: TFpDwarfSymbolType;
4133 ATargetCacheIndex: Integer): Boolean;
4134 var
4135 t: TFpDbgMemLocation;
4136 InitLocParserData: TInitLocParserData;
4137 begin
4138 t := AValueObj.DataAddressCache[ATargetCacheIndex];
4139 if IsInitializedLoc(t) then begin
4140 AnAddress := t;
4141 Result := IsValidLoc(AnAddress);
4142 end
4143 else begin
4144 InitInheritanceInfo;
4145 //TODO: may be a constant // offset
4146 InitLocParserData.ObjectDataAddress := AnAddress;
4147 InitLocParserData.ObjectDataAddrPush := True;
4148 Result := LocationFromTag(DW_AT_data_member_location, AValueObj, t, @InitLocParserData, FInheritanceInfo);
4149 if not Result then
4150 exit;
4151 AnAddress := t;
4152 AValueObj.DataAddressCache[ATargetCacheIndex] := AnAddress;
4153
4154 if IsError(AValueObj.MemManager.LastError) then
4155 SetLastError(AValueObj.MemManager.LastError);
4156 end;
4157
4158 Result := inherited GetDataAddressNext(AValueObj, AnAddress, ATargetType, ATargetCacheIndex);
4159 end;
4160
GetMembernull4161 function TFpDwarfSymbolTypeStructure.GetMember(AIndex: Int64): TFpDbgSymbol;
4162 var
4163 ti: TFpDbgSymbol;
4164 begin
4165 CreateMembers;
4166 if AIndex >= FMembers.Count then begin
4167 ti := TypeInfo;
4168 if ti <> nil then
4169 Result := ti.Member[AIndex - FMembers.Count];
4170 end
4171 else
4172 Result := TFpDbgSymbol(FMembers[AIndex]);
4173 end;
4174
4175 destructor TFpDwarfSymbolTypeStructure.Destroy;
4176 var
4177 i: Integer;
4178 begin
4179 ReleaseRefAndNil(FInheritanceInfo);
4180 if FMembers <> nil then begin
4181 for i := 0 to FMembers.Count - 1 do
4182 TFpDwarfSymbol(FMembers[i]).ParentTypeInfo := nil;
4183 FreeAndNil(FMembers);
4184 end;
4185 if FLastChildByName <> nil then begin
4186 FLastChildByName.ParentTypeInfo := nil;
4187 FLastChildByName.ReleaseCirclularReference;
4188 FLastChildByName := nil;
4189 end;
4190 inherited Destroy;
4191 end;
4192
4193 procedure TFpDwarfSymbolTypeStructure.CreateMembers;
4194 var
4195 Info: TDwarfInformationEntry;
4196 Info2: TDwarfInformationEntry;
4197 sym: TFpDwarfSymbol;
4198 begin
4199 if FMembers <> nil then
4200 exit;
4201 FMembers := TFpDbgCircularRefCntObjList.Create;
4202 Info := InformationEntry.Clone;
4203 Info.GoChild;
4204
4205 while Info.HasValidScope do begin
4206 if (Info.AbbrevTag = DW_TAG_member) or (Info.AbbrevTag = DW_TAG_subprogram) then begin
4207 Info2 := Info.Clone;
4208 sym := TFpDwarfSymbol.CreateSubClass('', Info2);
4209 FMembers.Add(sym);
4210 sym.ReleaseReference;
4211 sym.ParentTypeInfo := self;
4212 Info2.ReleaseReference;
4213 end;
4214 Info.GoNext;
4215 end;
4216
4217 Info.ReleaseReference;
4218 end;
4219
4220 procedure TFpDwarfSymbolTypeStructure.InitInheritanceInfo;
4221 begin
4222 if FInheritanceInfo = nil then
4223 FInheritanceInfo := InformationEntry.FindChildByTag(DW_TAG_inheritance);
4224 end;
4225
DoGetNestedTypeInfonull4226 function TFpDwarfSymbolTypeStructure.DoGetNestedTypeInfo: TFpDwarfSymbolType;
4227 var
4228 FwdInfoPtr: Pointer;
4229 FwdCompUint: TDwarfCompilationUnit;
4230 ParentInfo: TDwarfInformationEntry;
4231 begin
4232 Result:= nil;
4233 InitInheritanceInfo;
4234 if (FInheritanceInfo <> nil) and
4235 FInheritanceInfo.ReadReference(DW_AT_type, FwdInfoPtr, FwdCompUint)
4236 then begin
4237 ParentInfo := TDwarfInformationEntry.Create(FwdCompUint, FwdInfoPtr);
4238 //DebugLn(FPDBG_DWARF_SEARCH, ['Inherited from ', dbgs(ParentInfo.FInformationEntry, FwdCompUint) ]);
4239 Result := TFpDwarfSymbolType.CreateTypeSubClass('', ParentInfo);
4240 ParentInfo.ReleaseReference;
4241 end;
4242 end;
4243
4244 procedure TFpDwarfSymbolTypeStructure.KindNeeded;
4245 begin
4246 if (InformationEntry.AbbrevTag = DW_TAG_class_type) then
4247 SetKind(skClass)
4248 else
4249 begin
4250 if TypeInfo <> nil then // inheritance
4251 SetKind(skObject) // skClass
4252 else
4253 if MemberByName['_vptr$TOBJECT'] <> nil then
4254 SetKind(skObject) // skClass
4255 else
4256 if MemberByName['_vptr$'+Name] <> nil then
4257 SetKind(skObject)
4258 else
4259 SetKind(skRecord);
4260 end;
4261 end;
4262
GetTypedValueObjectnull4263 function TFpDwarfSymbolTypeStructure.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
4264 begin
4265 if ATypeCast then
4266 Result := TFpDwarfValueStructTypeCast.Create(Self)
4267 else
4268 Result := TFpDwarfValueStruct.Create(Self);
4269 end;
4270
4271 { TFpDwarfSymbolTypeArray }
4272
4273 procedure TFpDwarfSymbolTypeArray.CreateMembers;
4274 var
4275 Info, Info2: TDwarfInformationEntry;
4276 t: Cardinal;
4277 sym: TFpDwarfSymbol;
4278 begin
4279 if FMembers <> nil then
4280 exit;
4281 FMembers := TFpDbgCircularRefCntObjList.Create;
4282
4283 Info := InformationEntry.FirstChild;
4284 if Info = nil then exit;
4285
4286 while Info.HasValidScope do begin
4287 t := Info.AbbrevTag;
4288 if (t = DW_TAG_enumeration_type) or (t = DW_TAG_subrange_type) then begin
4289 Info2 := Info.Clone;
4290 sym := TFpDwarfSymbol.CreateSubClass('', Info2);
4291 FMembers.Add(sym);
4292 sym.ReleaseReference;
4293 sym.ParentTypeInfo := self;
4294 Info2.ReleaseReference;
4295 end;
4296 Info.GoNext;
4297 end;
4298
4299 Info.ReleaseReference;
4300 end;
4301
4302 procedure TFpDwarfSymbolTypeArray.ReadStride;
4303 var
4304 t: TFpDwarfSymbolType;
4305 begin
4306 if didtStrideRead in FDwarfArrayReadFlags then
4307 exit;
4308 Include(FDwarfArrayReadFlags, didtStrideRead);
4309 if InformationEntry.ReadValue(DW_AT_bit_stride, FStrideInBits) then
4310 exit;
4311
4312 CreateMembers;
4313 if (FMembers.Count > 0) and // TODO: stride for diff member
4314 (TDbgDwarfSymbolBase(FMembers[0]).InformationEntry.ReadValue(DW_AT_byte_stride, FStrideInBits))
4315 then begin
4316 FStrideInBits := FStrideInBits * 8;
4317 exit;
4318 end;
4319
4320 t := NestedTypeInfo;
4321 if t = nil then
4322 FStrideInBits := 0 // TODO error
4323 else
4324 FStrideInBits := t.Size * 8;
4325 end;
4326
4327 procedure TFpDwarfSymbolTypeArray.ReadOrdering;
4328 var
4329 AVal: Integer;
4330 begin
4331 if didtOrdering in FDwarfArrayReadFlags then
4332 exit;
4333 Include(FDwarfArrayReadFlags, didtOrdering);
4334 if InformationEntry.ReadValue(DW_AT_ordering, AVal) then
4335 FRowMajor := AVal = DW_ORD_row_major
4336 else
4337 FRowMajor := True; // default (at least in pas)
4338 end;
4339
4340 procedure TFpDwarfSymbolTypeArray.KindNeeded;
4341 begin
4342 SetKind(skArray); // Todo: static/dynamic?
4343 end;
4344
GetTypedValueObjectnull4345 function TFpDwarfSymbolTypeArray.GetTypedValueObject(ATypeCast: Boolean): TFpDwarfValue;
4346 begin
4347 Result := TFpDwarfValueArray.Create(Self);
4348 end;
4349
GetFlagsnull4350 function TFpDwarfSymbolTypeArray.GetFlags: TDbgSymbolFlags;
4351 function IsDynSubRange(m: TFpDwarfSymbol): Boolean;
4352 begin
4353 Result := sfSubRange in m.Flags;
4354 if not Result then exit;
4355 while (m <> nil) and not(m is TFpDwarfSymbolTypeSubRange) do
4356 m := m.NestedTypeInfo;
4357 Result := m <> nil;
4358 if not Result then exit; // TODO: should not happen, handle error
4359 Result := TFpDwarfSymbolTypeSubRange(m).FHighBoundState = rfValue; // dynamic high bound
4360 end;
4361 var
4362 m: TFpDbgSymbol;
4363 begin
4364 Result := inherited GetFlags;
4365 if (MemberCount = 1) then begin // TODO: move to freepascal specific
4366 m := Member[0];
4367 if (not m.HasBounds) or // e.g. Subrange with missing upper bound
4368 (m.OrdHighBound < m.OrdLowBound) or
4369 (IsDynSubRange(TFpDwarfSymbol(m)))
4370 then
4371 Result := Result + [sfDynArray]
4372 else
4373 Result := Result + [sfStatArray];
4374 end
4375 else
4376 Result := Result + [sfStatArray];
4377 end;
4378
GetMembernull4379 function TFpDwarfSymbolTypeArray.GetMember(AIndex: Int64): TFpDbgSymbol;
4380 begin
4381 CreateMembers;
4382 Result := TFpDbgSymbol(FMembers[AIndex]);
4383 end;
4384
GetMemberByNamenull4385 function TFpDwarfSymbolTypeArray.GetMemberByName(AIndex: String): TFpDbgSymbol;
4386 begin
4387 Result := nil; // no named members
4388 end;
4389
GetMemberCountnull4390 function TFpDwarfSymbolTypeArray.GetMemberCount: Integer;
4391 begin
4392 CreateMembers;
4393 Result := FMembers.Count;
4394 end;
4395
GetMemberAddressnull4396 function TFpDwarfSymbolTypeArray.GetMemberAddress(AValObject: TFpDwarfValue;
4397 const AIndex: array of Int64): TFpDbgMemLocation;
4398 var
4399 Idx, Offs, Factor: Int64;
4400 LowBound, HighBound: int64;
4401 i: Integer;
4402 bsize: Integer;
4403 m: TFpDwarfSymbol;
4404 begin
4405 assert((AValObject is TFpDwarfValueArray), 'TFpDwarfSymbolTypeArray.GetMemberAddress AValObject');
4406 ReadOrdering;
4407 ReadStride; // TODO Stride per member (member = dimension/index)
4408 Result := InvalidLoc;
4409 if (FStrideInBits <= 0) or (FStrideInBits mod 8 <> 0) then
4410 exit;
4411
4412 CreateMembers;
4413 if Length(AIndex) > FMembers.Count then
4414 exit;
4415
4416 if AValObject is TFpDwarfValueArray then begin
4417 if not TFpDwarfValueArray(AValObject).GetDwarfDataAddress(Result, Self) then begin
4418 Result := InvalidLoc;
4419 Exit;
4420 end;
4421 end
4422 else
4423 exit; // TODO error
4424
4425 Offs := 0;
4426 Factor := 1;
4427
4428 {$PUSH}{$R-}{$Q-} // TODO: check range of index
4429 bsize := FStrideInBits div 8;
4430 if FRowMajor then begin
4431 for i := Length(AIndex) - 1 downto 0 do begin
4432 Idx := AIndex[i];
4433 m := TFpDwarfSymbol(FMembers[i]);
4434 if ((m is TFpDwarfSymbolType) and (TFpDwarfSymbolType(m).GetValueBounds(AValObject, LowBound, HighBound))) or
4435 m.HasBounds then begin
4436 Idx := Idx - m.OrdLowBound;
4437 end;
4438 Offs := Offs + Idx * bsize * Factor;
4439 if i > 0 then begin
4440 if not m.HasBounds then begin
4441 Result := InvalidLoc;
4442 exit;
4443 end;
4444 // TODO range check
4445 Factor := Factor * (m.OrdHighBound - m.OrdLowBound + 1);
4446 end;
4447 end;
4448 end
4449 else begin
4450 for i := 0 to Length(AIndex) - 1 do begin
4451 Idx := AIndex[i];
4452 m := TFpDwarfSymbol(FMembers[i]);
4453 if m.HasBounds then begin
4454 Idx := Idx - m.OrdLowBound;
4455 end;
4456 Offs := Offs + Idx * bsize * Factor;
4457 if i < Length(AIndex) - 1 then begin
4458 if not m.HasBounds then begin
4459 Result := InvalidLoc;
4460 exit;
4461 end;
4462 Factor := Factor * (m.OrdHighBound - m.OrdLowBound + 1);
4463 end;
4464 end;
4465 end;
4466
4467 assert(IsTargetAddr(Result), 'DwarfArray MemberAddress');
4468 Result.Address := Result.Address + Offs;
4469 {$POP}
4470 end;
4471
4472 destructor TFpDwarfSymbolTypeArray.Destroy;
4473 var
4474 i: Integer;
4475 begin
4476 if FMembers <> nil then begin
4477 for i := 0 to FMembers.Count - 1 do
4478 TFpDwarfSymbol(FMembers[i]).ParentTypeInfo := nil;
4479 FreeAndNil(FMembers);
4480 end;
4481 inherited Destroy;
4482 end;
4483
4484 procedure TFpDwarfSymbolTypeArray.ResetValueBounds;
4485 var
4486 i: Integer;
4487 begin
4488 debuglnEnter(['TFpDwarfSymbolTypeArray.ResetValueBounds ' , Self.ClassName, dbgs(self)]); try
4489 inherited ResetValueBounds;
4490 FDwarfArrayReadFlags := [];
4491 if FMembers <> nil then
4492 for i := 0 to FMembers.Count - 1 do
4493 if TObject(FMembers[i]) is TFpDwarfSymbolType then
4494 TFpDwarfSymbolType(FMembers[i]).ResetValueBounds;
4495 finally debuglnExit(['TFpDwarfSymbolTypeArray.ResetValueBounds ' ]); end;
4496 end;
4497
4498 { TDbgDwarfSymbol }
4499
4500 constructor TFpDwarfSymbolValueProc.Create(ACompilationUnit: TDwarfCompilationUnit;
4501 AInfo: PDwarfAddressInfo; AAddress: TDbgPtr);
4502 var
4503 InfoEntry: TDwarfInformationEntry;
4504 begin
4505 FAddress := AAddress;
4506 FAddressInfo := AInfo;
4507
4508 InfoEntry := TDwarfInformationEntry.Create(ACompilationUnit, nil);
4509 InfoEntry.ScopeIndex := AInfo^.ScopeIndex;
4510
4511 inherited Create(
4512 String(FAddressInfo^.Name),
4513 InfoEntry
4514 );
4515
4516 SetAddress(TargetLoc(FAddressInfo^.StartPC));
4517
4518 InfoEntry.ReleaseReference;
4519 //BuildLineInfo(
4520
4521 // AFile: String = ''; ALine: Integer = -1; AFlags: TDbgSymbolFlags = []; const AReference: TDbgSymbol = nil);
4522 end;
4523
4524 destructor TFpDwarfSymbolValueProc.Destroy;
4525 begin
4526 FreeAndNil(FProcMembers);
4527 FLastMember.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember'){$ENDIF};
4528 FreeAndNil(FStateMachine);
4529 if FSelfParameter <> nil then begin
4530 //TDbgDwarfIdentifier(FSelfParameter.DbgSymbol).ParentTypeInfo := nil;
4531 FSelfParameter.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSelfParameter, 'FSelfParameter'){$ENDIF};
4532 end;
4533 inherited Destroy;
4534 end;
4535
GetColumnnull4536 function TFpDwarfSymbolValueProc.GetColumn: Cardinal;
4537 begin
4538 if StateMachineValid
4539 then Result := FStateMachine.Column
4540 else Result := inherited GetColumn;
4541 end;
4542
GetFilenull4543 function TFpDwarfSymbolValueProc.GetFile: String;
4544 begin
4545 if StateMachineValid
4546 then Result := FStateMachine.FileName
4547 else Result := inherited GetFile;
4548 end;
4549
GetLinenull4550 function TFpDwarfSymbolValueProc.GetLine: Cardinal;
4551 begin
4552 if StateMachineValid
4553 then Result := FStateMachine.Line
4554 else Result := inherited GetLine;
4555 end;
4556
GetValueObjectnull4557 function TFpDwarfSymbolValueProc.GetValueObject: TFpDbgValue;
4558 begin
4559 Result := FValueObject;
4560 if Result <> nil then exit;
4561
4562 FValueObject := TFpDwarfValue.Create(nil);
4563 {$IFDEF WITH_REFCOUNT_DEBUG}FValueObject.DbgRenameReference(@FValueObject, ClassName+'.FValueObject');{$ENDIF}
4564 FValueObject.MakePlainRefToCirclular;
4565 FValueObject.SetValueSymbol(self);
4566
4567 Result := FValueObject;
4568 end;
4569
StateMachineValidnull4570 function TFpDwarfSymbolValueProc.StateMachineValid: Boolean;
4571 var
4572 SM1, SM2: TDwarfLineInfoStateMachine;
4573 begin
4574 Result := FStateMachine <> nil;
4575 if Result then Exit;
4576
4577 if FAddressInfo^.StateMachine = nil
4578 then begin
4579 CompilationUnit.BuildLineInfo(FAddressInfo, False);
4580 if FAddressInfo^.StateMachine = nil then Exit;
4581 end;
4582
4583 // we cannot restore a statemachine to its current state
4584 // so we shouldn't modify FAddressInfo^.StateMachine
4585 // so use clones to navigate
4586 SM1 := FAddressInfo^.StateMachine.Clone;
4587 if FAddress < SM1.Address
4588 then begin
4589 // The address we want to find is before the start of this symbol ??
4590 SM1.Free;
4591 Exit;
4592 end;
4593 SM2 := FAddressInfo^.StateMachine.Clone;
4594
4595 repeat
4596 if (FAddress = SM1.Address)
4597 or not SM2.NextLine
4598 or (FAddress < SM2.Address)
4599 then begin
4600 // found
4601 FStateMachine := SM1;
4602 SM2.Free;
4603 Result := True;
4604 Exit;
4605 end;
4606 until not SM1.NextLine;
4607
4608 //if all went well we shouldn't come here
4609 SM1.Free;
4610 SM2.Free;
4611 end;
4612
ReadVirtualitynull4613 function TFpDwarfSymbolValueProc.ReadVirtuality(out AFlags: TDbgSymbolFlags): Boolean;
4614 var
4615 Val: Integer;
4616 begin
4617 AFlags := [];
4618 Result := InformationEntry.ReadValue(DW_AT_virtuality, Val);
4619 if not Result then exit;
4620 case Val of
4621 DW_VIRTUALITY_none: ;
4622 DW_VIRTUALITY_virtual: AFlags := [sfVirtual];
4623 DW_VIRTUALITY_pure_virtual: AFlags := [sfVirtual];
4624 end;
4625 end;
4626
4627 procedure TFpDwarfSymbolValueProc.CreateMembers;
4628 var
4629 Info: TDwarfInformationEntry;
4630 Info2: TDwarfInformationEntry;
4631 begin
4632 if FProcMembers <> nil then
4633 exit;
4634 FProcMembers := TRefCntObjList.Create;
4635 Info := InformationEntry.Clone;
4636 Info.GoChild;
4637
4638 while Info.HasValidScope do begin
4639 if ((Info.AbbrevTag = DW_TAG_formal_parameter) or (Info.AbbrevTag = DW_TAG_variable)) //and
4640 //not(Info.IsArtificial)
4641 then begin
4642 Info2 := Info.Clone;
4643 FProcMembers.Add(Info2);
4644 Info2.ReleaseReference;
4645 end;
4646 Info.GoNext;
4647 end;
4648
4649 Info.ReleaseReference;
4650 end;
4651
GetMembernull4652 function TFpDwarfSymbolValueProc.GetMember(AIndex: Int64): TFpDbgSymbol;
4653 begin
4654 CreateMembers;
4655 FLastMember.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember'){$ENDIF};
4656 FLastMember := TFpDwarfSymbol.CreateSubClass('', TDwarfInformationEntry(FProcMembers[AIndex]));
4657 {$IFDEF WITH_REFCOUNT_DEBUG}FLastMember.DbgRenameReference(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember');{$ENDIF}
4658 Result := FLastMember;
4659 end;
4660
GetMemberByNamenull4661 function TFpDwarfSymbolValueProc.GetMemberByName(AIndex: String): TFpDbgSymbol;
4662 var
4663 Info: TDwarfInformationEntry;
4664 s, s2: String;
4665 i: Integer;
4666 begin
4667 CreateMembers;
4668 s2 := LowerCase(AIndex);
4669 FLastMember.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember'){$ENDIF};
4670 FLastMember := nil;;
4671 for i := 0 to FProcMembers.Count - 1 do begin
4672 Info := TDwarfInformationEntry(FProcMembers[i]);
4673 if Info.ReadName(s) and (LowerCase(s) = s2) then begin
4674 FLastMember := TFpDwarfSymbol.CreateSubClass('', Info);
4675 {$IFDEF WITH_REFCOUNT_DEBUG}FLastMember.DbgRenameReference(@FLastMember, 'TFpDwarfSymbolValueProc.FLastMember');{$ENDIF}
4676 break;
4677 end;
4678 end;
4679 Result := FLastMember;
4680 end;
4681
GetMemberCountnull4682 function TFpDwarfSymbolValueProc.GetMemberCount: Integer;
4683 begin
4684 CreateMembers;
4685 Result := FProcMembers.Count;
4686 end;
4687
GetFrameBasenull4688 function TFpDwarfSymbolValueProc.GetFrameBase(ASender: TDwarfLocationExpression): TDbgPtr;
4689 var
4690 Val: TByteDynArray;
4691 begin
4692 Result := 0;
4693 if FFrameBaseParser = nil then begin
4694 //TODO: avoid copying data
4695 if not InformationEntry.ReadValue(DW_AT_frame_base, Val) then begin
4696 // error
4697 debugln(FPDBG_DWARF_ERRORS, ['TFpDwarfSymbolValueProc.GetFrameBase failed to read DW_AT_frame_base']);
4698 exit;
4699 end;
4700 if Length(Val) = 0 then begin
4701 // error
4702 debugln(FPDBG_DWARF_ERRORS, ['TFpDwarfSymbolValueProc.GetFrameBase failed to read DW_AT_location']);
4703 exit;
4704 end;
4705
4706 FFrameBaseParser := TDwarfLocationExpression.Create(@Val[0], Length(Val), CompilationUnit,
4707 ASender.MemManager, ASender.Context);
4708 FFrameBaseParser.Evaluate;
4709 end;
4710
4711 if FFrameBaseParser.ResultKind in [lseValue] then
4712 Result := FFrameBaseParser.ResultData;
4713
4714 if IsError(FFrameBaseParser.LastError) then begin
4715 SetLastError(FFrameBaseParser.LastError);
4716 debugln(FPDBG_DWARF_ERRORS, ['TFpDwarfSymbolValueProc.GetFrameBase location parser failed ', ErrorHandler.ErrorAsString(LastError)]);
4717 end
4718 else
4719 if Result = 0 then begin
4720 debugln(FPDBG_DWARF_ERRORS, ['TFpDwarfSymbolValueProc.GetFrameBase location parser failed. result is 0']);
4721 end;
4722
4723 end;
4724
4725 procedure TFpDwarfSymbolValueProc.KindNeeded;
4726 begin
4727 if TypeInfo <> nil then
4728 SetKind(skFunction)
4729 else
4730 SetKind(skProcedure);
4731 end;
4732
4733 procedure TFpDwarfSymbolValueProc.SizeNeeded;
4734 begin
4735 SetSize(FAddressInfo^.EndPC - FAddressInfo^.StartPC);
4736 end;
4737
GetFlagsnull4738 function TFpDwarfSymbolValueProc.GetFlags: TDbgSymbolFlags;
4739 var
4740 flg: TDbgSymbolFlags;
4741 begin
4742 Result := inherited GetFlags;
4743 if ReadVirtuality(flg) then
4744 Result := Result + flg;
4745 end;
4746
GetSelfParameternull4747 function TFpDwarfSymbolValueProc.GetSelfParameter(AnAddress: TDbgPtr): TFpDwarfValue;
4748 const
4749 this1: string = 'THIS';
4750 this2: string = 'this';
4751 self1: string = '$SELF';
4752 self2: string = '$self';
4753 var
4754 InfoEntry: TDwarfInformationEntry;
4755 tg: Cardinal;
4756 found: Boolean;
4757 begin
4758 // special: search "self"
4759 // Todo nested procs
4760 Result := FSelfParameter;
4761 if Result <> nil then exit;
4762
4763 InfoEntry := InformationEntry.Clone;
4764 //StartScopeIdx := InfoEntry.ScopeIndex;
4765 InfoEntry.GoParent;
4766 tg := InfoEntry.AbbrevTag;
4767 if (tg = DW_TAG_class_type) or (tg = DW_TAG_structure_type) then begin
4768 InfoEntry.ScopeIndex := InformationEntry.ScopeIndex;
4769 found := InfoEntry.GoNamedChildEx(@this1[1], @this2[1]);
4770 if not found then begin
4771 InfoEntry.ScopeIndex := InformationEntry.ScopeIndex;
4772 found := InfoEntry.GoNamedChildEx(@self1[1], @self2[1]);
4773 end;
4774 if found then begin
4775 if ((AnAddress = 0) or InfoEntry.IsAddressInStartScope(AnAddress)) and
4776 InfoEntry.IsArtificial
4777 then begin
4778 Result := TFpDwarfValue(TFpDwarfSymbolValue.CreateValueSubClass('self', InfoEntry).Value);
4779 FSelfParameter := Result;
4780 FSelfParameter.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSelfParameter, 'FSelfParameter'){$ENDIF};
4781 FSelfParameter.DbgSymbol.ReleaseReference;
4782 //FSelfParameter.DbgSymbol.ParentTypeInfo := Self;
4783 debugln(FPDBG_DWARF_SEARCH, ['TFpDwarfSymbolValueProc.GetSelfParameter ', InfoEntry.ScopeDebugText, DbgSName(Result)]);
4784 end;
4785 end;
4786 end;
4787 InfoEntry.ReleaseReference;
4788 end;
4789
4790 { TFpDwarfSymbolValueVariable }
4791
GetValueAddressnull4792 function TFpDwarfSymbolValueVariable.GetValueAddress(AValueObj: TFpDwarfValue; out
4793 AnAddress: TFpDbgMemLocation): Boolean;
4794 begin
4795 AnAddress := AValueObj.DataAddressCache[0];
4796 Result := IsValidLoc(AnAddress);
4797 if IsInitializedLoc(AnAddress) then
4798 exit;
4799 Result := LocationFromTag(DW_AT_location, AValueObj, AnAddress);
4800 AValueObj.DataAddressCache[0] := AnAddress;
4801 end;
4802
HasAddressnull4803 function TFpDwarfSymbolValueVariable.HasAddress: Boolean;
4804 begin
4805 Result := InformationEntry.HasAttrib(DW_AT_location);
4806 end;
4807
4808 { TFpDwarfSymbolValueParameter }
4809
GetValueAddressnull4810 function TFpDwarfSymbolValueParameter.GetValueAddress(AValueObj: TFpDwarfValue; out
4811 AnAddress: TFpDbgMemLocation): Boolean;
4812 begin
4813 AnAddress := AValueObj.DataAddressCache[0];
4814 Result := IsValidLoc(AnAddress);
4815 if IsInitializedLoc(AnAddress) then
4816 exit;
4817 Result := LocationFromTag(DW_AT_location, AValueObj, AnAddress);
4818 AValueObj.DataAddressCache[0] := AnAddress;
4819 end;
4820
HasAddressnull4821 function TFpDwarfSymbolValueParameter.HasAddress: Boolean;
4822 begin
4823 Result := InformationEntry.HasAttrib(DW_AT_location);
4824 end;
4825
GetFlagsnull4826 function TFpDwarfSymbolValueParameter.GetFlags: TDbgSymbolFlags;
4827 begin
4828 Result := (inherited GetFlags) + [sfParameter];
4829 end;
4830
4831 { TFpDwarfSymbolUnit }
4832
4833 procedure TFpDwarfSymbolUnit.Init;
4834 begin
4835 inherited Init;
4836 SetSymbolType(stNone);
4837 SetKind(skUnit);
4838 end;
4839
GetMemberByNamenull4840 function TFpDwarfSymbolUnit.GetMemberByName(AIndex: String): TFpDbgSymbol;
4841 var
4842 Ident: TDwarfInformationEntry;
4843 begin
4844 // Todo, param to only search external.
4845 ReleaseRefAndNil(FLastChildByName);
4846 Result := nil;
4847
4848 Ident := InformationEntry.Clone;
4849 Ident.GoNamedChildEx(AIndex);
4850 if Ident <> nil then
4851 Result := TFpDwarfSymbol.CreateSubClass('', Ident);
4852 // No need to set ParentTypeInfo
4853 ReleaseRefAndNil(Ident);
4854 FLastChildByName := Result;
4855 end;
4856
4857 destructor TFpDwarfSymbolUnit.Destroy;
4858 begin
4859 ReleaseRefAndNil(FLastChildByName);
4860 inherited Destroy;
4861 end;
4862
4863 initialization
4864 DwarfSymbolClassMapList.SetDefaultMap(TFpDwarfDefaultSymbolClassMap);
4865
4866 FPDBG_DWARF_VERBOSE := DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_VERBOSE' {$IFDEF FPDBG_DWARF_VERBOSE} , True {$ENDIF} );
4867 FPDBG_DWARF_ERRORS := DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_ERRORS' {$IFDEF FPDBG_DWARF_ERRORS} , True {$ENDIF} );
4868 FPDBG_DWARF_WARNINGS := DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_WARNINGS' {$IFDEF FPDBG_DWARF_WARNINGS} , True {$ENDIF} );
4869 FPDBG_DWARF_SEARCH := DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_SEARCH' {$IFDEF FPDBG_DWARF_SEARCH} , True {$ENDIF} );
4870 FPDBG_DWARF_DATA_WARNINGS := DebugLogger.FindOrRegisterLogGroup('FPDBG_DWARF_DATA_WARNINGS' {$IFDEF FPDBG_DWARF_DATA_WARNINGS} , True {$ENDIF} );
4871
4872 end.
4873
4874