diff --git a/windows/src/buildtools/sentrytool/Keyman.System.JclMapScanner.pas b/windows/src/buildtools/sentrytool/Keyman.System.JclMapScanner.pas
new file mode 100644
index 0000000000..34d0746e70
--- /dev/null
+++ b/windows/src/buildtools/sentrytool/Keyman.System.JclMapScanner.pas
@@ -0,0 +1,1166 @@
+//
+// This is a lightly modified version of TJclMapScanner, removing all reference
+// to loaded modules, as we don't use those for our map file conversion. All
+// unrelated code is excluded so we do not need to depend on the full JCL.
+//
+{**************************************************************************************************}
+{ }
+{ Project JEDI Code Library (JCL) }
+{ }
+{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
+{ you may not use this file except in compliance with the License. You may obtain a copy of the }
+{ License at http://www.mozilla.org/MPL/ }
+{ }
+{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF }
+{ ANY KIND, either express or implied. See the License for the specific language governing rights }
+{ and limitations under the License. }
+{ }
+{ The Original Code is JclDebug.pas. }
+{ }
+{ The Initial Developers of the Original Code are Petr Vones and Marcel van Brakel. }
+{ Portions created by these individuals are Copyright (C) of these individuals. }
+{ All Rights Reserved. }
+{ }
+{ Contributor(s): }
+{ Marcel van Brakel }
+{ Flier Lu (flier) }
+{ Florent Ouchet (outchy) }
+{ Robert Marquardt (marquardt) }
+{ Robert Rossmair (rrossmair) }
+{ Andreas Hausladen (ahuser) }
+{ Petr Vones (pvones) }
+{ Soeren Muehlbauer }
+{ Uwe Schuster (uschuster) }
+{ }
+{**************************************************************************************************}
+{ }
+{ Various debugging support routines and classes. This includes: Diagnostics routines, Trace }
+{ routines, Stack tracing and Source Locations a la the C/C++ __FILE__ and __LINE__ macros. }
+{ }
+{**************************************************************************************************}
+{ }
+{ Last modified: $Date:: $ }
+{ Revision: $Rev:: $ }
+{ Author: $Author:: $ }
+{ }
+{**************************************************************************************************}
+
+unit Keyman.System.JclMapScanner;
+
+interface
+
+uses
+ System.Classes,
+ System.SysUtils,
+ Winapi.Windows;
+
+type
+ TJclAddr32 = Cardinal;
+ TJclAddr64 = UInt64;
+
+ {$IFDEF _WIN64}
+ TJclAddr = TJclAddr64;
+ {$ELSE}
+ TJclAddr = TJclAddr32;
+ {$ENDIF}
+
+ PJclMapAddress = ^TJclMapAddress;
+ TJclMapAddress = packed record
+ Segment: Word;
+ Offset: TJclAddr;
+ end;
+
+ PJclMapString = PAnsiChar;
+
+ TJclFileMappingStream = class(TCustomMemoryStream)
+ private
+ FFileHandle: THandle;
+ FMapping: THandle;
+ protected
+ procedure Close;
+ public
+ constructor Create(const FileName: string; FileMode: Word = fmOpenRead or fmShareDenyWrite);
+ destructor Destroy; override;
+ function Write(const Buffer; Count: Longint): Longint; override;
+ end;
+
+ TJclAbstractMapParser = class(TObject)
+ private
+ FLinkerBug: Boolean;
+ FLinkerBugUnitName: PJclMapString;
+ FStream: TJclFileMappingStream;
+ function GetLinkerBugUnitName: string;
+ protected
+(* FModule: HMODULE;*)
+ FLastUnitName: PJclMapString;
+ FLastUnitFileName: PJclMapString;
+ procedure ClassTableItem(const Address: TJclMapAddress; Len: Integer; SectionName, GroupName: PJclMapString); virtual; abstract;
+ procedure SegmentItem(const Address: TJclMapAddress; Len: Integer; GroupName, UnitName: PJclMapString); virtual; abstract;
+ procedure PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString); virtual; abstract;
+ procedure PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString); virtual; abstract;
+ procedure LineNumberUnitItem(UnitName, UnitFileName: PJclMapString); virtual; abstract;
+ procedure LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress); virtual; abstract;
+ public
+ constructor Create(const MapFileName: TFileName; Module: HMODULE); overload; virtual;
+ constructor Create(const MapFileName: TFileName); overload;
+ destructor Destroy; override;
+ procedure Parse;
+ class function MapStringToFileName(MapString: PJclMapString): string;
+ class function MapStringToModuleName(MapString: PJclMapString): string;
+ class function MapStringToStr(MapString: PJclMapString; IgnoreSpaces: Boolean = False): string;
+ property LinkerBug: Boolean read FLinkerBug;
+ property LinkerBugUnitName: string read GetLinkerBugUnitName;
+ property Stream: TJclFileMappingStream read FStream;
+ end;
+
+ TJclMapStringCache = record
+ CachedValue: string;
+ RawValue: PJclMapString;
+ end;
+
+ // MAP file scanner
+ PJclMapSegmentClass = ^TJclMapSegmentClass;
+ TJclMapSegmentClass = record
+ Segment: Word; // segment ID
+ Start: DWORD; // start as in the map file
+ Addr: DWORD; // start as in process memory
+ VA: DWORD; // position relative to module base adress
+ Len: DWORD; // segment length
+ SectionName: TJclMapStringCache;
+ GroupName: TJclMapStringCache;
+ end;
+
+ PJclMapSegment = ^TJclMapSegment;
+ TJclMapSegment = record
+ Segment: Word;
+ StartVA: DWORD; // VA relative to (module base address + $10000)
+ EndVA: DWORD;
+ UnitName: TJclMapStringCache;
+ end;
+
+ PJclMapProcName = ^TJclMapProcName;
+ TJclMapProcName = record
+ Segment: Word;
+ VA: DWORD; // VA relative to (module base address + $10000)
+ ProcName: TJclMapStringCache;
+ end;
+
+ PJclMapLineNumber = ^TJclMapLineNumber;
+ TJclMapLineNumber = record
+ Segment: Word;
+ VA: DWORD; // VA relative to (module base address + $10000)
+ LineNumber: Integer;
+ end;
+
+ TJclMapScanner = class(TJclAbstractMapParser)
+ private
+ FSegmentClasses: array of TJclMapSegmentClass;
+ FLineNumbers: array of TJclMapLineNumber;
+ FProcNames: array of TJclMapProcName;
+ FSegments: array of TJclMapSegment;
+ FSourceNames: array of TJclMapProcName;
+ FLineNumbersCnt: Integer;
+ FLineNumberErrors: Integer;
+ FNewUnitFileName: PJclMapString;
+ FProcNamesCnt: Integer;
+ FSegmentCnt: Integer;
+ FLastAccessedSegementIndex: Integer;
+ function IndexOfSegment(Addr: DWORD): Integer;
+ protected
+ function MAPAddrToVA(const Addr: DWORD): DWORD;
+ procedure ClassTableItem(const Address: TJclMapAddress; Len: Integer; SectionName, GroupName: PJclMapString); override;
+ procedure SegmentItem(const Address: TJclMapAddress; Len: Integer; GroupName, UnitName: PJclMapString); override;
+ procedure PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString); override;
+ procedure PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString); override;
+ procedure LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress); override;
+ procedure LineNumberUnitItem(UnitName, UnitFileName: PJclMapString); override;
+ procedure Scan;
+ public
+ constructor Create(const MapFileName: TFileName; Module: HMODULE); override;
+
+ class function MapStringCacheToFileName(var MapString: TJclMapStringCache): string;
+ class function MapStringCacheToModuleName(var MapString: TJclMapStringCache): string;
+ class function MapStringCacheToStr(var MapString: TJclMapStringCache; IgnoreSpaces: Boolean = False): string;
+
+ // Addr are virtual addresses relative to (module base address + $10000)
+ function LineNumberFromAddr(Addr: DWORD): Integer; overload;
+ function LineNumberFromAddr(Addr: DWORD; out Offset: Integer): Integer; overload;
+ function ModuleNameFromAddr(Addr: DWORD): string;
+ function ModuleStartFromAddr(Addr: DWORD): DWORD;
+ function ProcNameFromAddr(Addr: DWORD): string; overload;
+ function ProcNameFromAddr(Addr: DWORD; out Offset: Integer): string; overload;
+ function SourceNameFromAddr(Addr: DWORD): string;
+ property LineNumberErrors: Integer read FLineNumberErrors;
+ end;
+
+implementation
+
+uses
+ System.AnsiStrings,
+ System.Character;
+
+//=== { TJclFileMappingStream } ==============================================
+
+constructor TJclFileMappingStream.Create(const FileName: string; FileMode: Word);
+var
+ Protect, Access, Size: DWORD;
+ BaseAddress: Pointer;
+begin
+ inherited Create;
+ FFileHandle := THandle(FileOpen(FileName, FileMode));
+ if FFileHandle = INVALID_HANDLE_VALUE then
+ RaiseLastOSError;
+ if (FileMode and $0F) = fmOpenReadWrite then
+ begin
+ Protect := PAGE_WRITECOPY;
+ Access := FILE_MAP_COPY;
+ end
+ else
+ begin
+ Protect := PAGE_READONLY;
+ Access := FILE_MAP_READ;
+ end;
+ FMapping := CreateFileMapping(FFileHandle, nil, Protect, 0, 0, nil);
+ if FMapping = 0 then
+ begin
+ Close;
+ RaiseLastOSError;
+ end;
+ BaseAddress := MapViewOfFile(FMapping, Access, 0, 0, 0);
+ if BaseAddress = nil then
+ begin
+ Close;
+ RaiseLastOSError;
+ end;
+ Size := GetFileSize(FFileHandle, nil);
+ if Size = DWORD(-1) then
+ begin
+ UnMapViewOfFile(BaseAddress);
+ Close;
+ RaiseLastOSError;
+ end;
+ SetPointer(BaseAddress, Size);
+end;
+
+destructor TJclFileMappingStream.Destroy;
+begin
+ Close;
+ inherited Destroy;
+end;
+
+procedure TJclFileMappingStream.Close;
+begin
+ if Memory <> nil then
+ begin
+ UnMapViewOfFile(Memory);
+ SetPointer(nil, 0);
+ end;
+ if FMapping <> 0 then
+ begin
+ CloseHandle(FMapping);
+ FMapping := 0;
+ end;
+ if FFileHandle <> INVALID_HANDLE_VALUE then
+ begin
+ FileClose(FFileHandle);
+ FFileHandle := INVALID_HANDLE_VALUE;
+ end;
+end;
+
+function TJclFileMappingStream.Write(const Buffer; Count: Integer): Longint;
+begin
+ Result := 0;
+ if (Size - Position) >= Count then
+ begin
+ System.Move(Buffer, Pointer(TJclAddr(Memory) + TJclAddr(Position))^, Count);
+ Position := Position + Count;
+ Result := Count;
+ end;
+end;
+
+//=== { TJclAbstractMapParser } ==============================================
+
+constructor TJclAbstractMapParser.Create(const MapFileName: TFileName; Module: HMODULE);
+begin
+ inherited Create;
+(* FModule := Module;*)
+ if FileExists(MapFileName) then
+ FStream := TJclFileMappingStream.Create(MapFileName, fmOpenRead or fmShareDenyWrite);
+end;
+
+constructor TJclAbstractMapParser.Create(const MapFileName: TFileName);
+begin
+ Create(MapFileName, 0);
+end;
+
+destructor TJclAbstractMapParser.Destroy;
+begin
+ FreeAndNil(FStream);
+ inherited Destroy;
+end;
+
+function TJclAbstractMapParser.GetLinkerBugUnitName: string;
+begin
+ Result := MapStringToStr(FLinkerBugUnitName);
+end;
+
+class function TJclAbstractMapParser.MapStringToFileName(MapString: PJclMapString): string;
+var
+ PEnd: PJclMapString;
+begin
+ if MapString = nil then
+ begin
+ Result := '';
+ Exit;
+ end;
+ PEnd := MapString;
+ while (PEnd^ <> #0) and not (PEnd^ in ['=', #10, #13]) do
+ Inc(PEnd);
+ if (PEnd^ = '=') then
+ begin
+ while (PEnd >= MapString) and (PEnd^ <> ' ') do
+ Dec(PEnd);
+ while (PEnd >= MapString) and ((PEnd-1)^ = ' ') do
+ Dec(PEnd);
+ end;
+ SetString(Result, MapString, PEnd - MapString);
+end;
+
+class function TJclAbstractMapParser.MapStringToModuleName(MapString: PJclMapString): string;
+var
+ PStart, PEnd, PExtension: PJclMapString;
+begin
+ if MapString = nil then
+ begin
+ Result := '';
+ Exit;
+ end;
+ PEnd := MapString;
+ while (PEnd^ <> #0) and not (PEnd^ in ['=', #10, #13]) do
+ Inc(PEnd);
+ if (PEnd^ = '=') then
+ begin
+ while (PEnd >= MapString) and (PEnd^ <> ' ') do
+ Dec(PEnd);
+ while (PEnd >= MapString) and ((PEnd-1)^ = ' ') do
+ Dec(PEnd);
+ end;
+ PExtension := PEnd;
+ while (PExtension >= MapString) and (PExtension^ <> '.') and (PExtension^ <> '|') do
+ Dec(PExtension);
+ if (System.AnsiStrings.StrIComp(PExtension, '.pas ') = 0) or
+ (System.AnsiStrings.StrIComp(PExtension, '.obj ') = 0) then
+ PEnd := PExtension;
+ PExtension := PEnd;
+ while (PExtension >= MapString) and (PExtension^ <> '|') and (PExtension^ <> '\') do
+ Dec(PExtension);
+ if PExtension >= MapString then
+ PStart := PExtension + 1
+ else
+ PStart := MapString;
+ SetString(Result, PStart, PEnd - PStart);
+end;
+
+class function TJclAbstractMapParser.MapStringToStr(MapString: PJclMapString;
+ IgnoreSpaces: Boolean): string;
+var
+ P: PJclMapString;
+begin
+ if MapString = nil then
+ begin
+ Result := '';
+ Exit;
+ end;
+ if MapString^ = '(' then
+ begin
+ Inc(MapString);
+ P := MapString;
+ while (P^ <> #0) and not (P^ in [')', #10, #13]) do
+ Inc(P);
+ end
+ else
+ begin
+ P := MapString;
+ if IgnoreSpaces then
+ while (P^ <> #0) and not (P^ in ['(', #10, #13]) do
+ Inc(P)
+ else
+ while (P^ <> #0) and (P^ <> '(') and (P^ > ' ') do
+ Inc(P);
+ end;
+ SetString(Result, MapString, P - MapString);
+end;
+
+const
+ NativeLineFeed = Char(#10);
+ NativeCarriageReturn = Char(#13);
+
+function CharIsReturn(const C: Char): Boolean;
+begin
+ Result := (C = NativeLineFeed) or (C = NativeCarriageReturn);
+end;
+
+function CharIsDigit(const C: Char): Boolean;
+begin
+ Result := C.IsDigit;
+end;
+
+procedure TJclAbstractMapParser.Parse;
+const
+ TableHeader : array [0..3] of string = ('Start', 'Length', 'Name', 'Class');
+ SegmentsHeader : array [0..3] of string = ('Detailed', 'map', 'of', 'segments');
+ PublicsByNameHeader : array [0..3] of string = ('Address', 'Publics', 'by', 'Name');
+ PublicsByValueHeader : array [0..3] of string = ('Address', 'Publics', 'by', 'Value');
+ LineNumbersPrefix : string = 'Line numbers for';
+var
+ CurrPos, EndPos: PJclMapString;
+{$IFNDEF COMPILER9_UP}
+ PreviousA,
+{$ENDIF COMPILER9_UP}
+ A: TJclMapAddress;
+ L: Integer;
+ P1, P2: PJclMapString;
+
+ function Eof: Boolean;
+ begin
+ Result := CurrPos >= EndPos;
+ end;
+
+ procedure SkipWhiteSpace;
+ var
+ LCurrPos, LEndPos: PJclMapString;
+ begin
+ LCurrPos := CurrPos;
+ LEndPos := EndPos;
+ while (LCurrPos < LEndPos) and (LCurrPos^ <= ' ') do
+ Inc(LCurrPos);
+ CurrPos := LCurrPos;
+ end;
+
+ procedure SkipEndLine;
+ begin
+ while not Eof and not CharIsReturn(Char(CurrPos^)) do
+ Inc(CurrPos);
+ SkipWhiteSpace;
+ end;
+
+ function IsDecDigit: Boolean;
+ begin
+ Result := CharIsDigit(Char(CurrPos^));
+ end;
+
+ function ReadTextLine: string;
+ var
+ P: PJclMapString;
+ begin
+ P := CurrPos;
+ while (P^ <> #0) and not (P^ in [#10, #13]) do
+ Inc(P);
+ SetString(Result, CurrPos, P - CurrPos);
+ CurrPos := P;
+ end;
+
+
+ function ReadDecValue: Integer;
+ var
+ P: PJclMapString;
+ begin
+ P := CurrPos;
+ Result := 0;
+ while P^ in ['0'..'9'] do
+ begin
+ Result := Result * 10 + (Ord(P^) - Ord('0'));
+ Inc(P);
+ end;
+ CurrPos := P;
+ end;
+
+ function ReadHexValue: DWORD;
+ var
+ C: AnsiChar;
+ begin
+ Result := 0;
+ repeat
+ C := CurrPos^;
+ case C of
+ '0'..'9':
+ Result := (Result shl 4) or DWORD(Ord(C) - Ord('0'));
+ 'A'..'F':
+ Result := (Result shl 4) or DWORD(Ord(C) - Ord('A') + 10);
+ 'a'..'f':
+ Result := (Result shl 4) or DWORD(Ord(C) - Ord('a') + 10);
+ 'H', 'h':
+ begin
+ Inc(CurrPos);
+ Break;
+ end;
+ else
+ Break;
+ end;
+ Inc(CurrPos);
+ until False;
+ end;
+
+ function ReadAddress: TJclMapAddress;
+ begin
+ Result.Segment := ReadHexValue;
+ if CurrPos^ = ':' then
+ begin
+ Inc(CurrPos);
+ Result.Offset := ReadHexValue;
+ end
+ else
+ Result.Offset := 0;
+ end;
+
+ function ReadString: PJclMapString;
+ begin
+ SkipWhiteSpace;
+ Result := CurrPos;
+ while {(CurrPos^ <> #0) and} (CurrPos^ > ' ') do
+ Inc(CurrPos);
+ end;
+
+ procedure FindParam(Param: AnsiChar);
+ begin
+ while not ((CurrPos^ = Param) and ((CurrPos + 1)^ = '=')) do
+ Inc(CurrPos);
+ Inc(CurrPos, 2);
+ end;
+
+ function SyncToHeader(const Header: array of string): Boolean;
+ var
+ S: string;
+ TokenIndex, OldPosition, CurrentPosition: Integer;
+ begin
+ Result := False;
+ while not Eof do
+ begin
+ S := Trim(ReadTextLine);
+ TokenIndex := Low(Header);
+ CurrentPosition := 0;
+ OldPosition := 0;
+ while (TokenIndex <= High(Header)) do
+ begin
+ CurrentPosition := Pos(Header[TokenIndex],S);
+ if (CurrentPosition <= OldPosition) then
+ begin
+ CurrentPosition := 0;
+ Break;
+ end;
+ OldPosition := CurrentPosition;
+ Inc(TokenIndex);
+ end;
+ Result := CurrentPosition <> 0;
+ if Result then
+ Break;
+ SkipEndLine;
+ end;
+ if not Eof then
+ SkipWhiteSpace;
+ end;
+
+ function SyncToPrefix(const Prefix: string): Boolean;
+ var
+ I: Integer;
+ P: PJclMapString;
+ S: string;
+ begin
+ if Eof then
+ begin
+ Result := False;
+ Exit;
+ end;
+ SkipWhiteSpace;
+ I := Length(Prefix);
+ P := CurrPos;
+ while not Eof and (P^ <> #13) and (P^ <> #0) and (I > 0) do
+ begin
+ Inc(P);
+ Dec(I);
+ end;
+ SetString(S, CurrPos, Length(Prefix));
+ Result := (S = Prefix);
+ if Result then
+ CurrPos := P;
+ SkipWhiteSpace;
+ end;
+
+begin
+ if FStream <> nil then
+ begin
+ FLinkerBug := False;
+{$IFNDEF COMPILER9_UP}
+ PreviousA.Segment := 0;
+ PreviousA.Offset := 0;
+{$ENDIF COMPILER9_UP}
+ CurrPos := FStream.Memory;
+ EndPos := CurrPos + FStream.Size;
+ if SyncToHeader(TableHeader) then
+ while IsDecDigit do
+ begin
+ A := ReadAddress;
+ SkipWhiteSpace;
+ L := ReadHexValue;
+ P1 := ReadString;
+ P2 := ReadString;
+ SkipEndLine;
+ ClassTableItem(A, L, P1, P2);
+ end;
+ if SyncToHeader(SegmentsHeader) then
+ while IsDecDigit do
+ begin
+ A := ReadAddress;
+ SkipWhiteSpace;
+ L := ReadHexValue;
+ FindParam('C');
+ P1 := ReadString;
+ FindParam('M');
+ P2 := ReadString;
+ SkipEndLine;
+ SegmentItem(A, L, P1, P2);
+ end;
+ if SyncToHeader(PublicsByNameHeader) then
+ while IsDecDigit do
+ begin
+ A := ReadAddress;
+ P1 := ReadString;
+ SkipEndLine; // compatibility with C++Builder MAP files
+ PublicsByNameItem(A, P1);
+ end;
+ if SyncToHeader(PublicsByValueHeader) then
+ while not Eof and IsDecDigit do
+ begin
+ A := ReadAddress;
+ P1 := ReadString;
+ SkipEndLine; // compatibility with C++Builder MAP files
+ PublicsByValueItem(A, P1);
+ end;
+ while SyncToPrefix(LineNumbersPrefix) do
+ begin
+ FLastUnitName := CurrPos;
+ FLastUnitFileName := CurrPos;
+ while FLastUnitFileName^ <> '(' do
+ Inc(FLastUnitFileName);
+ SkipEndLine;
+ LineNumberUnitItem(FLastUnitName, FLastUnitFileName);
+ repeat
+ SkipWhiteSpace;
+ L := ReadDecValue;
+ SkipWhiteSpace;
+ A := ReadAddress;
+ SkipWhiteSpace;
+ LineNumbersItem(L, A);
+{$IFNDEF COMPILER9_UP}
+ if (not FLinkerBug) and (A.Offset < PreviousA.Offset) then
+ begin
+ FLinkerBugUnitName := FLastUnitName;
+ FLinkerBug := True;
+ end;
+ PreviousA := A;
+{$ENDIF COMPILER9_UP}
+ until not IsDecDigit;
+ end;
+ end;
+end;
+
+//=== { TJclMapScanner } =====================================================
+
+constructor TJclMapScanner.Create(const MapFileName: TFileName; Module: HMODULE);
+begin
+ inherited Create(MapFileName, Module);
+ Scan;
+end;
+
+function TJclMapScanner.MAPAddrToVA(const Addr: DWORD): DWORD;
+begin
+ // MAP file format was changed in Delphi 2005
+ // before Delphi 2005: segments started at offset 0
+ // only one segment of code
+ // after Delphi 2005: segments started at code base address (module base address + $10000)
+ // 2 segments of code
+ if (Length(FSegmentClasses) > 0) and (FSegmentClasses[0].Start > 0) and (Addr >= FSegmentClasses[0].Start) then
+ // Delphi 2005 and later
+ // The first segment should be code starting at module base address + $10000
+ Result := Addr - FSegmentClasses[0].Start
+ else
+ // before Delphi 2005
+ Result := Addr;
+end;
+
+class function TJclMapScanner.MapStringCacheToFileName(
+ var MapString: TJclMapStringCache): string;
+begin
+ Result := MapString.CachedValue;
+ if Result = '' then
+ begin
+ Result := MapStringToFileName(MapString.RawValue);
+ MapString.CachedValue := Result;
+ end;
+end;
+
+class function TJclMapScanner.MapStringCacheToModuleName(
+ var MapString: TJclMapStringCache): string;
+begin
+ Result := MapString.CachedValue;
+ if Result = '' then
+ begin
+ Result := MapStringToModuleName(MapString.RawValue);
+ MapString.CachedValue := Result;
+ end;
+end;
+
+class function TJclMapScanner.MapStringCacheToStr(var MapString: TJclMapStringCache;
+ IgnoreSpaces: Boolean): string;
+begin
+ Result := MapString.CachedValue;
+ if Result = '' then
+ begin
+ Result := MapStringToStr(MapString.RawValue, IgnoreSpaces);
+ MapString.CachedValue := Result;
+ end;
+end;
+
+procedure TJclMapScanner.ClassTableItem(const Address: TJclMapAddress; Len: Integer;
+ SectionName, GroupName: PJclMapString);
+var
+ C: Integer;
+(* SectionHeader: PImageSectionHeader; *)
+begin
+ C := Length(FSegmentClasses);
+ SetLength(FSegmentClasses, C + 1);
+ FSegmentClasses[C].Segment := Address.Segment;
+ FSegmentClasses[C].Start := Address.Offset;
+ FSegmentClasses[C].Addr := Address.Offset; // will be fixed below while considering module mapped address
+ // test GroupName because SectionName = '.tls' in Delphi and '_tls' in BCB
+ if System.AnsiStrings.StrIComp(GroupName, 'TLS') = 0 then
+ FSegmentClasses[C].VA := FSegmentClasses[C].Start
+ else
+ FSegmentClasses[C].VA := MAPAddrToVA(FSegmentClasses[C].Start);
+ FSegmentClasses[C].Len := Len;
+ FSegmentClasses[C].SectionName.RawValue := SectionName;
+ FSegmentClasses[C].GroupName.RawValue := GroupName;
+(*
+ if FModule <> 0 then
+ begin
+ { Fix the section addresses }
+ SectionHeader := PeMapImgFindSectionFromModule(Pointer(FModule), MapStringToStr(SectionName));
+ if SectionHeader = nil then
+ { before Delphi 2005 the class names where used for the section names }
+ SectionHeader := PeMapImgFindSectionFromModule(Pointer(FModule), MapStringToStr(GroupName));
+
+ if SectionHeader <> nil then
+ begin
+ FSegmentClasses[C].Addr := TJclAddr(FModule) + SectionHeader.VirtualAddress;
+ FSegmentClasses[C].VA := SectionHeader.VirtualAddress;
+ end;
+ end;
+*)
+end;
+
+function TJclMapScanner.LineNumberFromAddr(Addr: DWORD): Integer;
+var
+ Dummy: Integer;
+begin
+ Result := LineNumberFromAddr(Addr, Dummy);
+end;
+
+function Search_MapLineNumber(Item1, Item2: Pointer): Integer;
+begin
+ Result := Integer(PJclMapLineNumber(Item1)^.VA) - PInteger(Item2)^;
+end;
+
+// Dynamic array sort and search routines
+type
+ TDynArraySortCompare = function (Item1, Item2: Pointer): Integer;
+ SizeInt = Integer;
+ PSizeInt = ^SizeInt;
+
+function SearchDynArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortCompare;
+ ValuePtr: Pointer; Nearest: Boolean): SizeInt;
+var
+ L, H, I, C: SizeInt;
+ B: Boolean;
+begin
+ Result := -1;
+ if ArrayPtr <> nil then
+ begin
+ L := 0;
+ H := PSizeInt(TJclAddr(ArrayPtr) - SizeOf(SizeInt))^ - 1;
+ B := False;
+ while L <= H do
+ begin
+ I := (L + H) shr 1;
+ C := SortFunc(Pointer(TJclAddr(ArrayPtr) + TJclAddr(I * SizeInt(ElementSize))), ValuePtr);
+ if C < 0 then
+ L := I + 1
+ else
+ begin
+ H := I - 1;
+ if C = 0 then
+ begin
+ B := True;
+ L := I;
+ end;
+ end;
+ end;
+ if B then
+ Result := L
+ else
+ if Nearest and (H >= 0) then
+ Result := H;
+ end;
+end;
+
+function TJclMapScanner.LineNumberFromAddr(Addr: DWORD; out Offset: Integer): Integer;
+var
+ I: Integer;
+ ModuleStartAddr: DWORD;
+begin
+ ModuleStartAddr := ModuleStartFromAddr(Addr);
+ Result := 0;
+ Offset := 0;
+ I := SearchDynArray(FLineNumbers, SizeOf(FLineNumbers[0]), Search_MapLineNumber, @Addr, True);
+ if (I <> -1) and (FLineNumbers[I].VA >= ModuleStartAddr) then
+ begin
+ Result := FLineNumbers[I].LineNumber;
+ Offset := Addr - FLineNumbers[I].VA;
+ end;
+end;
+
+procedure TJclMapScanner.LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress);
+var
+ SegIndex, C: Integer;
+ VA: DWORD;
+ Added: Boolean;
+begin
+ Added := False;
+ for SegIndex := Low(FSegmentClasses) to High(FSegmentClasses) do
+ if (FSegmentClasses[SegIndex].Segment = Address.Segment)
+ and (DWORD(Address.Offset) < FSegmentClasses[SegIndex].Len) then
+ begin
+ if System.AnsiStrings.StrIComp(FSegmentClasses[SegIndex].GroupName.RawValue, 'TLS') = 0 then
+ Va := Address.Offset
+ else
+ VA := MAPAddrToVA(Address.Offset + FSegmentClasses[SegIndex].Start);
+ { Starting with Delphi 2005, "empty" units are listes with the last line and
+ the VA 0001:00000000. When we would accept 0 VAs here, System.pas functions
+ could be mapped to other units and line numbers. Discaring such items should
+ have no impact on the correct information, because there can't be a function
+ that starts at VA 0. }
+ if VA = 0 then
+ Continue;
+ if FLineNumbersCnt = Length(FLineNumbers) then
+ begin
+ if FLineNumbersCnt < 512 then
+ SetLength(FLineNumbers, FLineNumbersCnt + 512)
+ else
+ SetLength(FLineNumbers, FLineNumbersCnt * 2);
+ end;
+ FLineNumbers[FLineNumbersCnt].Segment := FSegmentClasses[SegIndex].Segment;
+ FLineNumbers[FLineNumbersCnt].VA := VA;
+ FLineNumbers[FLineNumbersCnt].LineNumber := LineNumber;
+ Inc(FLineNumbersCnt);
+ Added := True;
+ if FNewUnitFileName <> nil then
+ begin
+ C := Length(FSourceNames);
+ SetLength(FSourceNames, C + 1);
+ FSourceNames[C].Segment := FSegmentClasses[SegIndex].Segment;
+ FSourceNames[C].VA := VA;
+ FSourceNames[C].ProcName.RawValue := FNewUnitFileName;
+ FNewUnitFileName := nil;
+ end;
+ Break;
+ end;
+ if not Added then
+ Inc(FLineNumberErrors);
+end;
+
+procedure TJclMapScanner.LineNumberUnitItem(UnitName, UnitFileName: PJclMapString);
+begin
+ FNewUnitFileName := UnitFileName;
+end;
+
+function TJclMapScanner.IndexOfSegment(Addr: DWORD): Integer;
+var
+ L, R: Integer;
+ S: PJclMapSegment;
+begin
+ R := Length(FSegments) - 1;
+ Result := FLastAccessedSegementIndex;
+ if Result <= R then
+ begin
+ S := @FSegments[Result];
+ if (S.StartVA <= Addr) and (Addr < S.EndVA) then
+ Exit;
+ end;
+
+ // binary search
+ L := 0;
+ while L <= R do
+ begin
+ Result := L + (R - L) div 2;
+ S := @FSegments[Result];
+ if Addr >= S.EndVA then
+ L := Result + 1
+ else
+ begin
+ R := Result - 1;
+ if (S.StartVA <= Addr) and (Addr < S.EndVA) then
+ begin
+ FLastAccessedSegementIndex := Result;
+ Exit;
+ end;
+ end;
+ end;
+ Result := -1;
+end;
+
+function TJclMapScanner.ModuleNameFromAddr(Addr: DWORD): string;
+var
+ I: Integer;
+begin
+ I := IndexOfSegment(Addr);
+ if I <> -1 then
+ Result := MapStringCacheToModuleName(FSegments[I].UnitName)
+ else
+ Result := '';
+end;
+
+function TJclMapScanner.ModuleStartFromAddr(Addr: DWORD): DWORD;
+var
+ I: Integer;
+begin
+ I := IndexOfSegment(Addr);
+ Result := DWORD(-1);
+ if I <> -1 then
+ Result := FSegments[I].StartVA;
+end;
+
+function TJclMapScanner.ProcNameFromAddr(Addr: DWORD): string;
+var
+ Dummy: Integer;
+begin
+ Result := ProcNameFromAddr(Addr, Dummy);
+end;
+
+function Search_MapProcName(Item1, Item2: Pointer): Integer;
+begin
+ Result := Integer(PJclMapProcName(Item1)^.VA) - PInteger(Item2)^;
+end;
+
+function TJclMapScanner.ProcNameFromAddr(Addr: DWORD; out Offset: Integer): string;
+var
+ I: Integer;
+ ModuleStartAddr: DWORD;
+begin
+ ModuleStartAddr := ModuleStartFromAddr(Addr);
+ Result := '';
+ Offset := 0;
+ I := SearchDynArray(FProcNames, SizeOf(FProcNames[0]), Search_MapProcName, @Addr, True);
+ if (I <> -1) and (FProcNames[I].VA >= ModuleStartAddr) then
+ begin
+ Result := MapStringCacheToStr(FProcNames[I].ProcName, True);
+ Offset := Addr - FProcNames[I].VA;
+ end;
+end;
+
+procedure TJclMapScanner.PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString);
+begin
+ { TODO : What to do? }
+end;
+
+procedure TJclMapScanner.PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString);
+var
+ SegIndex: Integer;
+begin
+ for SegIndex := Low(FSegmentClasses) to High(FSegmentClasses) do
+ if (FSegmentClasses[SegIndex].Segment = Address.Segment)
+ and (DWORD(Address.Offset) < FSegmentClasses[SegIndex].Len) then
+ begin
+ if FProcNamesCnt = Length(FProcNames) then
+ begin
+ if FProcNamesCnt < 512 then
+ SetLength(FProcNames, FProcNamesCnt + 512)
+ else
+ SetLength(FProcNames, FProcNamesCnt * 2);
+ end;
+ FProcNames[FProcNamesCnt].Segment := FSegmentClasses[SegIndex].Segment;
+ if System.AnsiStrings.StrIComp(FSegmentClasses[SegIndex].GroupName.RawValue, 'TLS') = 0 then
+ FProcNames[FProcNamesCnt].VA := Address.Offset
+ else
+ FProcNames[FProcNamesCnt].VA := MAPAddrToVA(Address.Offset + FSegmentClasses[SegIndex].Start);
+ FProcNames[FProcNamesCnt].ProcName.RawValue := Name;
+ Inc(FProcNamesCnt);
+ Break;
+ end;
+end;
+
+function Sort_MapLineNumber(Item1, Item2: Pointer): Integer;
+begin
+ Result := Integer(PJclMapLineNumber(Item1)^.VA) - Integer(PJclMapLineNumber(Item2)^.VA);
+end;
+
+function Sort_MapProcName(Item1, Item2: Pointer): Integer;
+begin
+ Result := Integer(PJclMapProcName(Item1)^.VA) - Integer(PJclMapProcName(Item2)^.VA);
+end;
+
+function Sort_MapSegment(Item1, Item2: Pointer): Integer;
+begin
+ Result := Integer(PJclMapSegment(Item1)^.StartVA) - Integer(PJclMapSegment(Item2)^.StartVA);
+end;
+
+type
+ TDynByteArray = array of Byte;
+
+procedure SortDynArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortCompare);
+var
+ TempBuf: TDynByteArray;
+
+ function ArrayItemPointer(Item: SizeInt): Pointer;
+ begin
+ Assert(Item >= 0);
+ Result := Pointer(TJclAddr(ArrayPtr) + TJclAddr(Item * SizeInt(ElementSize)));
+ end;
+
+ procedure QuickSort(L, R: SizeInt);
+ var
+ I, J, T: SizeInt;
+ P, IPtr, JPtr: Pointer;
+ ElSize: Integer;
+ begin
+ ElSize := ElementSize;
+ repeat
+ I := L;
+ J := R;
+ P := ArrayItemPointer((L + R) shr 1);
+ repeat
+ IPtr := ArrayItemPointer(I);
+ JPtr := ArrayItemPointer(J);
+ while SortFunc(IPtr, P) < 0 do
+ begin
+ Inc(I);
+ Inc(PByte(IPtr), ElSize);
+ end;
+ while SortFunc(JPtr, P) > 0 do
+ begin
+ Dec(J);
+ Dec(PByte(JPtr), ElSize);
+ end;
+ if I <= J then
+ begin
+ if I <> J then
+ begin
+ case ElementSize of
+ SizeOf(Byte):
+ begin
+ T := PByte(IPtr)^;
+ PByte(IPtr)^ := PByte(JPtr)^;
+ PByte(JPtr)^ := T;
+ end;
+ SizeOf(Word):
+ begin
+ T := PWord(IPtr)^;
+ PWord(IPtr)^ := PWord(JPtr)^;
+ PWord(JPtr)^ := T;
+ end;
+ SizeOf(Integer):
+ begin
+ T := PInteger(IPtr)^;
+ PInteger(IPtr)^ := PInteger(JPtr)^;
+ PInteger(JPtr)^ := T;
+ end;
+ else
+ Move(IPtr^, TempBuf[0], ElementSize);
+ Move(JPtr^, IPtr^, ElementSize);
+ Move(TempBuf[0], JPtr^, ElementSize);
+ end;
+ end;
+ if P = IPtr then
+ P := JPtr
+ else
+ if P = JPtr then
+ P := IPtr;
+ Inc(I);
+ Dec(J);
+ end;
+ until I > J;
+ if L < J then
+ QuickSort(L, J);
+ L := I;
+ until I >= R;
+ end;
+
+begin
+ if ArrayPtr <> nil then
+ begin
+ SetLength(TempBuf, ElementSize);
+ QuickSort(0, PSizeInt(TJclAddr(ArrayPtr) - SizeOf(SizeInt))^ - 1);
+ end;
+end;
+
+procedure TJclMapScanner.Scan;
+begin
+ FLineNumberErrors := 0;
+ FSegmentCnt := 0;
+ FProcNamesCnt := 0;
+ FLastAccessedSegementIndex := 0;
+ Parse;
+ SetLength(FLineNumbers, FLineNumbersCnt);
+ SetLength(FProcNames, FProcNamesCnt);
+ SetLength(FSegments, FSegmentCnt);
+ SortDynArray(FLineNumbers, SizeOf(FLineNumbers[0]), Sort_MapLineNumber);
+ SortDynArray(FProcNames, SizeOf(FProcNames[0]), Sort_MapProcName);
+ SortDynArray(FSegments, SizeOf(FSegments[0]), Sort_MapSegment);
+ SortDynArray(FSourceNames, SizeOf(FSourceNames[0]), Sort_MapProcName);
+end;
+
+procedure TJclMapScanner.SegmentItem(const Address: TJclMapAddress; Len: Integer;
+ GroupName, UnitName: PJclMapString);
+var
+ SegIndex: Integer;
+ VA: DWORD;
+begin
+ for SegIndex := Low(FSegmentClasses) to High(FSegmentClasses) do
+ if (FSegmentClasses[SegIndex].Segment = Address.Segment)
+ and (DWORD(Address.Offset) < FSegmentClasses[SegIndex].Len) then
+ begin
+ if System.AnsiStrings.StrIComp(FSegmentClasses[SegIndex].GroupName.RawValue, 'TLS') = 0 then
+ VA := Address.Offset
+ else
+ VA := MAPAddrToVA(Address.Offset + FSegmentClasses[SegIndex].Start);
+ if FSegmentCnt mod 16 = 0 then
+ SetLength(FSegments, FSegmentCnt + 16);
+ FSegments[FSegmentCnt].Segment := FSegmentClasses[SegIndex].Segment;
+ FSegments[FSegmentCnt].StartVA := VA;
+ FSegments[FSegmentCnt].EndVA := VA + DWORD(Len);
+ FSegments[FSegmentCnt].UnitName.RawValue := UnitName;
+ Inc(FSegmentCnt);
+ Break;
+ end;
+end;
+
+function TJclMapScanner.SourceNameFromAddr(Addr: DWORD): string;
+var
+ I: Integer;
+ ModuleStartVA: DWORD;
+begin
+ // try with line numbers first (Delphi compliance)
+ ModuleStartVA := ModuleStartFromAddr(Addr);
+ Result := '';
+ I := SearchDynArray(FSourceNames, SizeOf(FSourceNames[0]), Search_MapProcName, @Addr, True);
+ if (I <> -1) and (FSourceNames[I].VA >= ModuleStartVA) then
+ Result := MapStringCacheToStr(FSourceNames[I].ProcName);
+ if Result = '' then
+ begin
+ // try with module names (C++Builder compliance)
+ I := IndexOfSegment(Addr);
+ if I <> -1 then
+ Result := MapStringCacheToFileName(FSegments[I].UnitName);
+ end;
+end;
+
+end.
+
diff --git a/windows/src/buildtools/sentrytool/Keyman.System.MapToSym.pas b/windows/src/buildtools/sentrytool/Keyman.System.MapToSym.pas
index f5c90cba2c..1ffa354f0e 100644
--- a/windows/src/buildtools/sentrytool/Keyman.System.MapToSym.pas
+++ b/windows/src/buildtools/sentrytool/Keyman.System.MapToSym.pas
@@ -8,7 +8,7 @@ uses
System.SysUtils,
Winapi.Windows,
- JclDebug;
+ Keyman.System.JclMapScanner;
type
TMapToSymFindFileProc = function(const UnitName: string): string;
@@ -69,7 +69,7 @@ var
s: TJclMapScannerCracker;
r: TStringList;
i: Integer;
- fileName, groupName, unitName: string;
+ fileName, unitName: string;
procCount, lineCount: Integer;
procLen, lineIndex, lineLen: Integer;
procName: string;
diff --git a/windows/src/buildtools/sentrytool/sentrytool.dpr b/windows/src/buildtools/sentrytool/sentrytool.dpr
index f1ed8450b6..0f275594aa 100644
--- a/windows/src/buildtools/sentrytool/sentrytool.dpr
+++ b/windows/src/buildtools/sentrytool/sentrytool.dpr
@@ -9,7 +9,8 @@ uses
Keyman.System.SentryTool.SentryToolMain in 'Keyman.System.SentryTool.SentryToolMain.pas',
Keyman.System.MapToSym in 'Keyman.System.MapToSym.pas',
Keyman.System.AddPdbToPe in 'Keyman.System.AddPdbToPe.pas',
- Keyman.System.SentryTool.DelphiSearchFile in 'Keyman.System.SentryTool.DelphiSearchFile.pas';
+ Keyman.System.SentryTool.DelphiSearchFile in 'Keyman.System.SentryTool.DelphiSearchFile.pas',
+ Keyman.System.JclMapScanner in 'Keyman.System.JclMapScanner.pas';
begin
try
diff --git a/windows/src/buildtools/sentrytool/sentrytool.dproj b/windows/src/buildtools/sentrytool/sentrytool.dproj
index 2e2743555d..a711b8689f 100644
--- a/windows/src/buildtools/sentrytool/sentrytool.dproj
+++ b/windows/src/buildtools/sentrytool/sentrytool.dproj
@@ -97,6 +97,7 @@
+
Cfg_2
Base
@@ -138,7 +139,7 @@
true
-
+
sentrytool.exe
true