paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-12-16 02:00:30 +01:00
Code Issues Packages Projects Releases Wiki Activity

FPDebug: string compare (none case) utf8 and faster

Browse Source 
git-svn-id: trunk@43411 -
This commit is contained in:
martin 2013-11-09 22:41:44 +00:00
parent 83d2aeba85
commit 310df63d6f
2 changed files with 101 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
components/fpdebug/fpdbgdwarf.pas
View File

@ -41,9 +41,9 @@ unit FpDbgDwarf;
interface
uses
Classes, Types, SysUtils, FpDbgInfo, FpDbgDwarfConst, Maps, Math,
Classes, Types, SysUtils, FpDbgUtil, FpDbgInfo, FpDbgDwarfConst, Maps, Math,
FpDbgLoader, FpImgReaderBase, LazLoggerBase, // LazLoggerDummy,
LazClasses, LazFileUtils, contnrs;
LazClasses, LazFileUtils, LazUTF8, contnrs;
type
// compilation unit header
@ -289,6 +289,7 @@ type
function ReadValue(AnAttrib: Cardinal; out AValue: Int64): Boolean;
function ReadValue(AnAttrib: Cardinal; out AValue: Cardinal): Boolean;
function ReadValue(AnAttrib: Cardinal; out AValue: QWord): Boolean;
function ReadValue(AnAttrib: Cardinal; out AValue: PChar): Boolean;
function ReadValue(AnAttrib: Cardinal; out AValue: String): Boolean;
function ReadReference(AnAttrib: Cardinal; out AValue: Pointer; out ACompUnit: TDwarfCompilationUnit): Boolean;
public
@ -1687,19 +1688,24 @@ end;
function TDwarfInformationEntry.GoNamedChild(AName: String): Boolean;
var
EntryName: String;
s: String;
EntryName: PChar;
s1, s2: String;
begin
Result := False;
s := UpperCase(AName);
if AName = '' then
exit;
GoChild;
if not HasValidScope then
exit;
s1 := UTF8UpperCase(AName);
s2 := UTF8LowerCase(AName);
while HasValidScope do begin
if not ReadValue(DW_AT_name, EntryName) then begin
GoNext;
Continue;
end;
if UpperCase(EntryName) = s then begin
if CompareUtf8BothCase(@s1[1], @s2[1], EntryName) then begin
// TODO: check DW_AT_start_scope;
DebugLn([FPDBG_DWARF_SEARCH, 'GoNamedChild found ', dbgs(FScope, FCompUnit), DbgSName(Self)]);
Result := True;
@ -1712,15 +1718,20 @@ end;
function TDwarfInformationEntry.GoNamedChildEx(AName: String): Boolean;
var
EntryName: String;
s: String;
EntryName: PChar;
s1, s2: String;
InEnum: Boolean;
ParentScopIdx: Integer;
begin
Result := False;
InEnum := False;
s := UpperCase(AName);
if AName = '' then
exit;
GoChild;
if not HasValidScope then
exit;
s1 := UTF8UpperCase(AName);
s2 := UTF8LowerCase(AName);
while true do begin
while HasValidScope do begin
if not ReadValue(DW_AT_name, EntryName) then begin
@ -1728,7 +1739,7 @@ begin
Continue;
end;
if UpperCase(EntryName) = s then begin
if CompareUtf8BothCase(@s1[1], @s2[1], EntryName) then begin
// TODO: check DW_AT_start_scope;
DebugLn([FPDBG_DWARF_SEARCH, 'GoNamedChildEx found ', dbgs(FScope, FCompUnit), DbgSName(Self)]);
Result := True;
@ -1886,6 +1897,16 @@ begin
Result := FCompUnit.ReadValue(AData, FAbbrevData[i].Form, AValue);
end;
function TDwarfInformationEntry.ReadValue(AnAttrib: Cardinal; out AValue: PChar): Boolean;
var
AData: pointer;
i: Integer;
begin
i := AttribIdx(AnAttrib, AData);
if i < 0 then exit(False);
Result := FCompUnit.ReadValue(AData, FAbbrevData[i].Form, AValue);
end;
function TDwarfInformationEntry.ReadValue(AnAttrib: Cardinal; out AValue: String): Boolean;
var
AData: pointer;
@ -1977,7 +1998,8 @@ var
//Scope,
StartScopeIdx, ExtVal, i: Integer;
InfoEntry, InfoEntryTmp, InfoEntryParent: TDwarfInformationEntry;
s, InfoName: String;
s, s1, s2: String;
InfoName: PChar;
FwdInfoPtr: Pointer;
tg: Cardinal;
begin
@ -1986,7 +2008,8 @@ begin
exit;
SubRoutine := TDbgDwarfProcSymbol(FSymbol);
s := UpperCase(AName);
s1 := UTF8UpperCase(AName);
s2 := UTF8LowerCase(AName);
try
CU := SubRoutine.FCU;
@ -1999,7 +2022,7 @@ begin
StartScopeIdx := InfoEntry.ScopeIndex;
if InfoEntry.ReadValue(DW_AT_name, InfoName) then begin
if UpperCase(InfoName) = s then begin
if (AName <> '') and (CompareUtf8BothCase(@s1[1], @s2[1], InfoName)) then begin
Result := TDbgDwarfIdentifier.CreateSubClass(AName, InfoEntry);
DebugLn(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier found ', dbgs(InfoEntry.FScope, CU), DbgSName(Result)]);
exit;
@ -2055,7 +2078,8 @@ begin
if not InfoEntry.Abbrev.tag = DW_TAG_compile_unit then
continue;
if UpperCase(CU2.UnitName) = s then begin
s := CU2.UnitName;
if (AName <> '') and (s <> '') and (CompareUtf8BothCase(@s1[1], @s2[1], @s[1])) then begin
Result := TDbgDwarfIdentifier.CreateSubClass(AName, InfoEntry);
DebugLn(FPDBG_DWARF_SEARCH, ['TDbgDwarf.FindIdentifier found unit ', dbgs(InfoEntry.FScope, CU2), DbgSName(Result)]);
break;
@ -2373,12 +2397,17 @@ end;
function TDbgDwarfIdentifierEnum.GetMemberByName(AIndex: String): TDbgSymbol;
var
i: Integer;
s, s1, s2: String;
begin
if AIndex = '' then
s1 := UTF8UpperCase(AIndex);
s2 := UTF8LowerCase(AIndex);
CreateMembers;
i := FMembers.Count - 1;
while i >= 0 do begin
Result := TDbgSymbol(FMembers[i]);
if UpperCase(AIndex) = UpperCase(Result.Name) then
s := Result.Name;
if (s <> '') and CompareUtf8BothCase(@s1[1], @s2[1], @s[1]) then
exit;
dec(i);
end;

57
components/fpdebug/fpdbgutil.pp
View File

@ -45,6 +45,7 @@ type
THexValueFormatFlags = set of THexValueFormatFlag;
function CompareUtf8BothCase(AnUpper, AnLower, AnUnknown: PChar): Boolean;
function AlignPtr(Src: Pointer; Alignment: Byte): Pointer;
function HexValue(const AValue; ASize: Byte; AFlags: THexValueFormatFlags): String;
procedure Log(const AText: String; const AParams: array of const); overload;
@ -53,6 +54,62 @@ procedure Log(const AText: String); overload;
implementation
function CompareUtf8BothCase(AnUpper, AnLower, AnUnknown: PChar): Boolean;
var
p: PChar;
begin
Result := False;
while (AnUpper^ <> #0) and (AnUnknown^ <> #0) do begin
p := AnUnknown;
if (AnUpper^ = AnUnknown^) then begin
// maybe uppercase
inc(AnUpper);
inc(AnUnknown);
while ((byte(AnUpper^) and $C0) = $C0) and (AnUpper^ = AnUnknown^) do begin
inc(AnUpper);
inc(AnUnknown);
end;
if ((byte(AnUpper^) and $C0) <> $C0) then begin // equal to upper
inc(AnLower);
while ((byte(AnLower^) and $C0) = $C0) do
inc(AnLower);
Continue;
end;
end
else begin
// skip the first byte / continuation bytes are skipped if lower matches
inc(AnUpper);
inc(AnUnknown);
end;
// Not upper, try lower
if (AnLower^ = p^) then begin
inc(AnLower);
inc(p);
while ((byte(AnLower^) and $C0) = $C0) and (AnLower^ = p^) do begin
inc(AnLower);
inc(p);
end;
if ((byte(AnLower^) and $C0) <> $C0) then begin // equal to lower
// adjust upper and unknown to codepoint
while ((byte(AnUpper^) and $C0) = $C0) do
inc(AnUnknown);
while ((byte(AnUnknown^) and $C0) = $C0) do
inc(AnUnknown);
Continue;
end;
end;
Result := False;
exit;
end;
Result := AnUpper^ = AnUnknown^; // both #0
end;
function AlignPtr(Src: Pointer; Alignment: Byte): Pointer;
begin
Result := Pointer(((PtrUInt(Src) + Alignment - 1) and not PtrUInt(Alignment - 1)));