Debugger: Converter, match "*" and inheritance via "is:"

components/fpdebug/fpdbgdwarffreepascal.pas

@@ -157,10 +157,13 @@ type
     //function GetInstanceClass(AValueObj: TFpValueDwarf): TFpSymbolDwarf; override;
     class function GetInstanceClassNameFromPVmt(APVmt: TDbgPtr;
       AContext: TFpDbgLocationContext; ASizeOfAddr: Integer;
-      out AClassName: String; out AnError: TFpError): boolean;
+      out AClassName: String; out AnError: TFpError;
+      AParentClassIndex: integer = 0;
+      ACompilerVersion: Cardinal = 0): boolean;
   public
     function GetInstanceClassName(AValueObj: TFpValue; out
-      AClassName: String): boolean; override;
+      AClassName: String;
+      AParentClassIndex: integer = 0): boolean; override;
   end;
 
   (* *** Record vs ShortString *** *)
@@ -965,7 +968,8 @@ begin
 end;
 
 function TFpSymbolDwarfFreePascalTypeStructure.GetInstanceClassName(
-  AValueObj: TFpValue; out AClassName: String): boolean;
+  AValueObj: TFpValue; out AClassName: String; AParentClassIndex: integer
+  ): boolean;
 var
   AnErr: TFpError;
 begin
@@ -973,21 +977,27 @@ begin
   if not Result then
     exit;
   Result := GetInstanceClassNameFromPVmt(LocToAddrOrNil(AValueObj.DataAddress),
-    TFpValueDwarf(AValueObj).Context, TFpValueDwarf(AValueObj).Context.SizeOfAddress, AClassName, AnErr);
+    TFpValueDwarf(AValueObj).Context, TFpValueDwarf(AValueObj).Context.SizeOfAddress,
+    AClassName, AnErr, AParentClassIndex,
+    TFpDwarfFreePascalSymbolClassMap(CompilationUnit.DwarfSymbolClassMap).FCompilerVersion
+  );
+
   if not Result then
     SetLastError(AValueObj, AnErr);
 end;
 
 class function TFpSymbolDwarfFreePascalTypeStructure.GetInstanceClassNameFromPVmt
   (APVmt: TDbgPtr; AContext: TFpDbgLocationContext; ASizeOfAddr: Integer; out
-  AClassName: String; out AnError: TFpError): boolean;
+  AClassName: String; out AnError: TFpError; AParentClassIndex: integer;
+  ACompilerVersion: Cardinal): boolean;
 var
-  VmtAddr, ClassNameAddr: TFpDbgMemLocation;
+  VmtAddr, ClassNameAddr, A: TFpDbgMemLocation;
   NameLen: QWord;
 begin
   Result := False;
   AnError := NoError;
   AClassName := '';
+
   if not AContext.ReadAddress(TargetLoc(APVmt), SizeVal(ASizeOfAddr), VmtAddr) then begin
     AnError := AContext.LastMemError;
     exit;
@@ -996,6 +1006,37 @@ begin
     AnError := CreateError(fpErrCanNotReadMemAtAddr, [VmtAddr.Address]);
     exit;
   end;
+
+  while AParentClassIndex > 0 do begin
+    {$PUSH}{$Q-}
+    VmtAddr.Address := VmtAddr.Address + TDBGPtr(2 * ASizeOfAddr);
+    {$POP}
+    A := VmtAddr;
+    if not AContext.ReadAddress(A, SizeVal(ASizeOfAddr), VmtAddr) then begin
+      AnError := AContext.LastMemError;
+      exit;
+    end;
+    if not IsReadableMem(VmtAddr) then begin
+      AnError := CreateError(fpErrCanNotReadMemAtAddr, [VmtAddr.Address]);
+      exit;
+    end;
+
+    if (ACompilerVersion >= $030200)
+    then begin
+      A := VmtAddr;
+      if not AContext.ReadAddress(A, SizeVal(ASizeOfAddr), VmtAddr) then begin
+        AnError := AContext.LastMemError;
+        exit;
+      end;
+      if not IsReadableMem(VmtAddr) then begin
+        AnError := CreateError(fpErrCanNotReadMemAtAddr, [VmtAddr.Address]);
+        exit;
+      end;
+    end;
+
+    dec(AParentClassIndex);
+  end;
+
   {$PUSH}{$Q-}
   VmtAddr.Address := VmtAddr.Address + TDBGPtr(3 * ASizeOfAddr);
   {$POP}

components/fpdebug/fpdbginfo.pas

@@ -187,7 +187,7 @@ type
   public
     function GetTypeCastedValue(ADataVal: TFpValue): TFpValue; virtual; // only if Symbol is a type
 
-    function GetInstanceClassName(out AClassName: String): boolean; virtual;
+    function GetInstanceClassName(out AClassName: String; AParentClassIndex: integer = 0): boolean; virtual;
 
 // base class? Or Member includes member from base
     (* Member:
@@ -463,7 +463,7 @@ type
     //
     property Flags: TDbgSymbolFlags read GetFlags;
     property Parent: TFpSymbol read GetParent; deprecated;
-    function GetInstanceClassName(AValueObj: TFpValue; out AClassName: String): boolean; virtual;
+    function GetInstanceClassName(AValueObj: TFpValue; out AClassName: String; AParentClassIndex: integer = 0): boolean; virtual;
 
     // for Subranges  // Type-Symbols only?
     // TODO: flag bounds as cardinal if needed
@@ -508,7 +508,7 @@ type
     function GetNestedSymbolByName(const AIndex: String): TFpSymbol; override;
     function GetNestedSymbolCount: Integer; override;
   public
-    function GetInstanceClassName(AValueObj: TFpValue; out AClassName: String): boolean; override;
+    function GetInstanceClassName(AValueObj: TFpValue; out AClassName: String; AParentClassIndex: integer = 0): boolean; override;
     function GetValueBounds(AValueObj: TFpValue; out ALowBound, AHighBound: Int64): Boolean; override;
     function GetValueLowBound(AValueObj: TFpValue; out ALowBound: Int64): Boolean; override;
     function GetValueHighBound(AValueObj: TFpValue; out AHighBound: Int64): Boolean; override;
@@ -929,14 +929,15 @@ begin
   Result := nil;
 end;
 
-function TFpValue.GetInstanceClassName(out AClassName: String): boolean;
+function TFpValue.GetInstanceClassName(out AClassName: String;
+  AParentClassIndex: integer): boolean;
 var
   ti: TFpSymbol;
 begin
   ti := TypeInfo;
   Result := ti <> nil;
   if Result then
-    Result := ti.GetInstanceClassName(Self, AClassName);
+    Result := ti.GetInstanceClassName(Self, AClassName, AParentClassIndex);
 end;
 
 procedure TFpValue.ResetError;
@@ -1396,7 +1397,7 @@ begin
 end;
 
 function TFpSymbol.GetInstanceClassName(AValueObj: TFpValue; out
-  AClassName: String): boolean;
+  AClassName: String; AParentClassIndex: integer): boolean;
 begin
   AClassName := '';
   Result := False;
@@ -1777,15 +1778,15 @@ begin
 end;
 
 function TFpSymbolForwarder.GetInstanceClassName(AValueObj: TFpValue; out
-  AClassName: String): boolean;
+  AClassName: String; AParentClassIndex: integer): boolean;
 var
   p: TFpSymbol;
 begin
   p := GetForwardToSymbol;
   if p <> nil then
-    Result := p.GetInstanceClassName(AValueObj, AClassName)
+    Result := p.GetInstanceClassName(AValueObj, AClassName, AParentClassIndex)
   else
-    Result := inherited GetInstanceClassName(AValueObj, AClassName);
+    Result := inherited GetInstanceClassName(AValueObj, AClassName, AParentClassIndex);
 end;
 
 function TFpSymbolForwarder.GetValueBounds(AValueObj: TFpValue; out

components/lazdebuggers/lazdebuggerfp/fpdebugvalueconvertors.pas

@@ -6,9 +6,9 @@ interface
 
 uses
   Classes, SysUtils, fgl, FpDbgInfo, FpdMemoryTools, FpDbgCallContextInfo,
-  FpPascalBuilder, FpErrorMessages, FpDbgClasses, FpDbgUtil, DbgIntfBaseTypes,
+  FpPascalBuilder, FpErrorMessages, FpDbgClasses, FpDbgUtil,
-  lazCollections, LazClasses, LCLProc, FpDebugDebuggerBase,
+  DbgIntfBaseTypes, lazCollections, LazClasses, LCLProc, StrUtils,
-  LazDebuggerIntfBaseTypes;
+  FpDebugDebuggerBase, LazDebuggerIntfBaseTypes;
 
 type
   TDbgSymbolKinds = set of TDbgSymbolKind;
@@ -59,6 +59,7 @@ type
     procedure Assign(ASource: TFpDbgConverterConfig); virtual;
 
     function CheckMatch(AValue: TFpValue): Boolean;
+    function CheckTypeMatch(AValue: TFpValue): Boolean;
     property Converter: TFpDbgValueConverter read FConverter write SetConverter;
 
     property MatchKinds: TDbgSymbolKinds read FMatchKinds write FMatchKinds;
@@ -212,11 +213,104 @@ var
   t: TFpSymbol;
   TpName: String;
 begin
-  t := AValue.TypeInfo;
   Result := (AValue.Kind in (FMatchKinds * Converter.GetSupportedKinds)) and
-            (t <> nil) and
+            CheckTypeMatch(AValue);
-            GetTypeName(TpName, t, [tnfNoSubstitute]) and
+end;
-            (FMatchTypeNames.IndexOf(TpName) >= 0);
+
+function TFpDbgConverterConfig.CheckTypeMatch(AValue: TFpValue): Boolean;
+  function MatchPattern(const AName, APattern: String): Boolean;
+  var
+    NamePos, PatternPos, p: Integer;
+  begin
+    Result := False;
+    if APattern = '' then
+      exit;
+
+    NamePos := 1;
+    PatternPos := 1;
+
+    while PatternPos <= Length(APattern) do begin
+      if APattern[PatternPos] = '*' then begin
+        inc(PatternPos);
+      end
+      else begin
+        p := PatternPos;
+        PatternPos := PosEx('*', APattern, p);
+        if PatternPos < 1 then
+          PatternPos := Length(APattern)+1;
+        if PatternPos-p > Length(AName)+1 - NamePos then
+          break;
+
+        NamePos := PosEx(Copy(APattern, p, PatternPos-p), AName, NamePos);
+        if (NamePos < 1) or
+           ( (p = 1) and (NamePos <> 1) ) // APattern does not start with *
+        then
+          break;
+
+        inc(NamePos, PatternPos-p);
+      end;
+    end;
+
+    Result := (PatternPos = Length(APattern)+1) and
+              ( (NamePos = Length(AName)+1) or
+                ( (APattern[Length(APattern)] = '*') and
+                  (NamePos <= Length(AName)+1)
+                )
+              );
+  end;
+var
+  i, CnIdx: Integer;
+  TpName, Pattern, ValClassName: String;
+  t: TFpSymbol;
+begin
+  t := AValue.TypeInfo;
+  Result := (t <> nil) and GetTypeName(TpName, t, [tnfNoSubstitute]);
+  if not Result then
+    exit;
+
+  TpName := LowerCase(TpName);
+  i := FMatchTypeNames.Count;
+  while i > 0 do begin
+    dec(i);
+    Pattern := LowerCase(trim(FMatchTypeNames[i]));
+
+    if AnsiStrLIComp('is:', @Pattern[1], 3) = 0 then begin
+      Delete(Pattern, 1, 3);
+      Pattern := trim(Pattern);
+
+      if  (AValue.Kind in [skRecord, skClass, skObject, skInterface]) then begin
+        ValClassName := TpName;
+        while t <> nil do begin
+          Result := MatchPattern(ValClassName, Pattern);
+          if Result then
+            exit;
+          t := t.TypeInfo;
+          if (t = nil) or not GetTypeName(ValClassName, t, [tnfNoSubstitute]) then
+            break;
+          ValClassName := LowerCase(ValClassName);
+        end;
+
+        CnIdx := 0;
+        while AValue.GetInstanceClassName(ValClassName, CnIdx) and
+              (ValClassName <> '')
+        do begin
+          ValClassName := LowerCase(ValClassName);
+          if ValClassName = TpName then
+            Break;
+          Result := MatchPattern(ValClassName, Pattern);
+          if Result then
+            exit;
+          inc(CnIdx);
+        end;
+
+        Continue;
+      end;
+    end;
+
+    Result := MatchPattern(TpName, Pattern);
+    if Result then
+      exit;
+  end;
 end;
 
 { TFpDbgConverterConfigList }