OS/2 Shareware BBS: 10 Tools/10-Tools.zip/vp21beta.zip/ARTLSRC.RAR/HEAPCHK.PAS

Pascal/Delphi Source File | 2000-08-15 | 25KB | 795 lines

{█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
{█                                                       █}
{█      Virtual Pascal version 2.1                       █}
{█      Heap checking routines                           █}
{█      ─────────────────────────────────────────────────█}
{█      Copyright (C) 2000 Allan Mertner                 █}
{█                                                       █}
{▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}

// To use, include this unit in the program as the first unit in the
// Uses clause.

// To not use automatically, compile it with the HEAPCHK_MANUAL conditional
// define, which also disables over-and under-run detection.

// If HEAPCHK_MANUAL is specified, call InitHeapCheck to install the
// heap checker.

{$Delphi+,Use32+}

unit HeapChk;

interface

type
  tOnProblem    = procedure( _AllocatedAt: Pointer );

// -------[ Main heap checker entry point ]------------------------------ \\

procedure InitHeapCheck( const _LogFile: String; _OnProblem: tOnProblem );

implementation

uses
  VpSysLow, SysUtils, Objects, Dos;

type
  // -------[ A heapblock, copied from system.pas ]---------------------- \\
  PBlockRec = ^TBlockRec;
  TBlockRec = record            // Heap free sub-block record
    Next:      PBlockRec;       // Pointer to the next free sub-block
    Size:      Longint;         // Size of the sub-block
  end;

  TProblems = (pNotFreed, pUnderrun, pOverrun);
  TProbSet  = set of TProblems;

  // -------[ Information on a single memory allocation ]---------------- \\
  PAllocationInfo = ^TAllocationInfo;
  TAllocationInfo = object(TObject)
    fAddress : Pointer;  // Address of allocated memory
    fSize    : Longint;  // Size of allocated block
    fCaller  : Pointer;  // Address of caller
    fIndex   : Longint;  // Sequentiel allocation number
    fVmt     : Pointer;  // If class variable, this is a class reference
    fType    : Byte;     // Type of allocation, vt* constants
    fProblem : TProbSet; // Overrun, underrrun, freemem problem?

    constructor Init( _Address, _Caller, _Class: Pointer; _Size, _Index: Longint );
    function VmtPtr: Pointer;
    function ClassName: String;
    function StringValue: PChar;
    function ProblemCode: Char;
  end;

  // -------[ Container for all memory allocations, sorted by number ]--- \\
  TAllocationList = object(TSortedCollection)
    function Compare(Key1, Key2: Pointer): Integer; virtual;
    function KeyOf(Item: Pointer): Pointer; virtual;

    procedure NewAllocation( var _Address: Pointer; _Caller, _Object: Pointer; _Size: Longint );
    procedure FreeAllocation( var _Address: Pointer; var _Problems: TProbSet );
  end;

  PProblemInfo = ^TProblemInfo;
  TProblemInfo = object(TObject)
    fIndex   : Longint;  // Number of allocation causing problem
    fProblem : TProbSet; // Problems with allocation

    constructor Init( _Index: Longint; _ProblemCode: char );
  end;

  // -------[ Container for previous memory problems, sorted by index ]-- \\
  TProblemIndexList = object(TSortedCollection)
    function Compare(Key1, Key2: Pointer): Integer; virtual;
  end;

  // -------[ Simple log file container class ]-------------------------- \\
  TLogFile = object
  private
    fLog: Text;
    fUpdate: Integer;
    fLines: Integer;
  protected
    procedure LoadProblems( var _ProblemList: TProblemIndexList );
    procedure ListProblems( const _AllocList: TAllocationList );
  public
    constructor Init( const _LogFile: String );
    destructor Done;
    procedure AddLine( const _s: String );
    procedure AddLineFmt( const _s: String; const _Args: array of const );
    procedure BeginUpdate;
    procedure EndUpdate;
  end;

// ---------------------------------------------------------------------- \\
// -------[ Internally used globals and constants ]---------------------- \\
// ---------------------------------------------------------------------- \\

var
  AllocationList: TAllocationList;     // Global list of unfreed allocs
  ProblemList: TProblemIndexList;      // List of problems from previous run
  LogFile: TLogFile;                   // Log file used to load/store info

const
  OnProblem   : tOnProblem = nil;      // User routine called on problem alloc
  MemMgrIndex : Longint = 0;           // Running index of memory allocation
  MaxBlocks   : Longint = 0;           // Max. allocated blocks of memory
  MaxMemory   : Longint = 0;           // Max. allocated heap memory
  CurMemory   : Longint = 0;           // Currently allocated heap memory
  Overruns    : Longint = 0;           // Number of overruns
  Underruns   : Longint = 0;           // Number of underruns

  SysVerified : LongBool = False;      // True, if System unit verified
  HeapChkOn   : Boolean = False;       // True, if HeapChk is enabled

{$IFNDEF HEAPCHK_MANUAL}
  StartOffset = 4;                     // Offset where real data begins
  ExtraAlloc  = 8;                     // Extra memory to allocate
  heapchk_BufferBegin   = $AC4BF321;   // Begin buffer for Underrun chk
  heapchk_BufferEnd     = $9723CA3B;   // End buffer for Overrun chk
{$ELSE}
  StartOffset = 0;                     // No offset when not overrun checking
{$ENDIF}

// ---------------------------------------------------------------------- \\
// -------[ TLogFile: handling of log file ]----------------------------- \\
// ---------------------------------------------------------------------- \\

constructor TLogFile.Init( const _LogFile: String );
var
  Temp: String;
  FileName: String;
begin
  FileName := _LogFile;
  if FileName = '' then
    begin
      Temp := GetEnv( 'TEMP' );
      if Temp = '' then
        Temp := GetEnv( 'TMP' );
      if ( Temp <> '' ) and ( Temp[Length(Temp)] <> SysPathSep ) then
        Temp := Temp + SysPathSep;
      FileName := ExtractFileName( ParamStr(0) );
      FileName := Temp + ChangeFileExt( FileName, '.mem' );
    end;
  Writeln( '!! HeapChk FileName is ',FileName);
  Assign( fLog, FileName );
  fUpdate := 0;
  fLines := 0;
end;

destructor TLogFile.Done;
begin
  if fUpdate > 0 then
    close( fLog );
end;

procedure TLogFile.AddLine( const _s: String );
begin
  BeginUpdate;
  inc( fLines );
  Writeln( fLog, _s );
  EndUpdate;
end;

procedure TLogFile.AddLineFmt( const _s: String; const _Args: array of const );
begin
  AddLine( Format( _s, _Args ) );
end;

procedure TLogFile.BeginUpdate;
begin
  inc( fUpdate );
  if fUpdate = 1 then
    begin
      if fLines = 0 then
        Rewrite( fLog )
      else
        begin
          {$I-}
          Append( fLog );
          {$I+}
          if IOResult <> 0 then
            Rewrite( fLog );
        end;
    end;
end;

procedure TLogFile.EndUpdate;
begin
  dec( fUpdate );
  if fUpdate = 0 then
    Close( fLog );
end;

procedure TLogFile.LoadProblems( var _ProblemList: TProblemIndexList );
var
  Line: String;
  Index: Longint;
  Problem: PProblemInfo;

begin
  _ProblemList.Init( 100, 100 );
  if fUpdate <> 0 then
    exit;
  {$I-}
  Reset( fLog );
  {$I+}
  if IOResult <> 0 then
    exit;

  while not eof( fLog ) do
    begin
      Readln( fLog, Line );
      if Line[1] = '!' then
        begin
          Index := StrToIntDef( Copy(Line, 4, 7), -1 );
          if Index <> -1 then
            begin
              Problem := New( PProblemInfo, Init( Index, Line[2] ) );
              _ProblemList.Insert( Problem );
            end;
        end;

    end;
  close( fLog );
end;

const
  DumpLength = 24;

procedure TLogFile.ListProblems( const _AllocList: TAllocationList );
  function ProblemLine( const _pItem: pAllocationInfo ): String;
  var
    sContent: String;
    sLoc: String;
    pSource: Pointer;
    FileName: String;
    LineNo: Integer;
    pC: pChar;
    i: Integer;

  begin
    // Construct contents of unfreed pointer
    case _pItem^.fType of
      vtObject     : sContent := Format( '(vmt: %p)', [_pItem^.VmtPtr] );
      vtClass      : sContent := Format( '(%s)', [_pItem.ClassName] );
      vtAnsiString : sContent := Format( '(str: ''%s'')', [_pItem.StringValue] );
    else
      begin
        pC := pChar(_pItem^.fAddress) + StartOffset;
        sContent := '';
        i := 0;
        while (i < DumpLength) and (i < _pItem^.fSize - 2*StartOffset) do
          begin
            if pC^ >= ' ' then
              sContent := sContent + pC^
            else
              sContent := sContent + '.';
            inc(i);
            inc(pC);
          end;
      end;
    end;
    Result := Format( '!%s %7d %p %8d %-*s',
                      [_pItem^.ProblemCode, _pItem^.fIndex,
                       _pItem^.fAddress, _pItem^.fSize, DumpLength,
                       sContent] );

    // Determine where Problem originated
    if _pItem^.fCaller = nil then
      sLoc := ' [Unknown]'
    else
      begin
        pSource := GetLocationInfo( _pItem^.fCaller, FileName, LineNo );
        if pSource = nil then          // Source not found
          sLoc := Format( ' [Addr = %p]', [_pItem^.fCaller] )
        else                           // Source found
          sLoc := Format( ' [%s #%d]', [FileName, LineNo] );
      end;

    Result := Result + sLoc;
  end;

  function GetNumberLine( const _s: String; _Value: Integer ): String;
  var
    Fmt: String;
  begin
    if _Value = 0 then
      Fmt := 'no '
    else
      Fmt := '%d ';
    Result := Format( Fmt + _s, [_Value] );
    if _Value <> 1 then
      Result := Result + 's';
  end;

var
  AllocInx: Longint;
  s: String;
  Fmt: String;

begin
  BeginUpdate;

  if fLines > 0 then
    AddLine( '' );

  // Write list of memory Problems.  This list is also read and used for
  // automatic positioning on the next run
  if _AllocList.Count > 0 then
    begin
      AddLine( '  ] List of problematic memory blocks [ ');
      AddLine( '    (p is bitmapped; bit 0 - leak; bit 1 - overrun; bit 2 - underrun)');
      AddLine( '    ----' );
      AddLine( ' p   Index  Address    Bytes Data                     [Allocated from]');
      AddLine( ' - ------- -------- -------- ------------------------ ----------------');
      for AllocInx := 0 to _AllocList.Count-1 do
        AddLine( ProblemLine( _AllocList.At(AllocInx) ) );
      AddLine( '' );
    end;

  // Write a summary of problems
  AddLine( '  ] Summary [' );
  AddLine( '    -------' );
  s := Format( '  Leaked blocks %d; Leaked mem %d; max blocks %d; max mem %d',
               [_AllocList.Count, CurMemory, MaxBlocks, MaxMemory]);
  AddLine( s );

{$IFNDEF HEAPCHK_MANUAL}
  // Summarize over-and underruns
  s := '  ' + GetNumberLine( 'overrun', Overruns );
  s := s + '; ' + GetNumberLine( 'underrun', Underruns );
  AddLine( s );
{$ENDIF}
  EndUpdate;
end;

// ---------------------------------------------------------------------- \\
// -------[ Handler when error detected ]-------------------------------- \\
// ---------------------------------------------------------------------- \\

const
  // Error codes for heap checking
  heap_freeinvalidmemory = 1;
  heap_SizeCorrupt       = 2;
  heapchk_underrun       = 3;
  heapchk_overrun        = 4;
  heapchk_system         = 5;

procedure ErrorHandler( _Code: Integer; P: Pointer );
var
  s: String;

begin
  case _Code of
    heap_freeinvalidmemory :
      s := 'Freeing unallocated memory at %p';
    heap_SizeCorrupt :
      s := 'Size of allocation corrupted for %p';
    heapchk_system :
      s := 'System Unit inconsistent; caller addresses unavailable.';
  else
    s := 'Unknown error (%p)';
  end;
  s := Format( s, [P] );
  if LogFile.fLines = 0 then
    begin
      LogFile.AddLine( '  ] Errors occurred during execution [');
      LogFile.AddLine( '    ------');
    end;
  LogFile.AddLine( '  ! ' + s );
end;

// ---------------------------------------------------------------------- \\
// -------[ TProblemInfo: A single problem ]----------------------------- \\
// ---------------------------------------------------------------------- \\

constructor TproblemInfo.Init( _Index: Longint; _ProblemCode: Char );
var
  i: Byte;
begin
  fIndex   := _Index;
  i := ord(_ProblemCode) - ord('0');
  fProblem := TProbSet( i );
end;


// ---------------------------------------------------------------------- \\
// -------[ TProblemIndexList: List of Problems from previous run ]------------ \\
// ---------------------------------------------------------------------- \\

function TProblemIndexList.Compare(Key1, Key2: Pointer): Integer;
begin
  Result := PProblemInfo(Key1)^.fIndex - PProblemInfo(Key2)^.fIndex;
end;

// ---------------------------------------------------------------------- \\
// -------[ TAllocationInfo - information about a single allocation ]---- \\
// ---------------------------------------------------------------------- \\

constructor TAllocationInfo.Init( _Address, _Caller, _Class: Pointer; _Size, _Index: Longint );
begin
  fAddress := _Address;
  fSize    := _Size;
  fIndex   := _Index;
  fCaller  := _Caller;

  if _Class = nil then
    fType  := 0
  else if Longint(_Class) = 2 then
    begin
      fType  := vtAnsiString;
      _Class := nil;
    end
  else if Longint(_Class) and 1 = 1 then
    begin
      fType := vtObject;
      _Class := Pointer(Longint(_Class) and $fffffffe)
    end
  else
    fType := vtClass;
  fVmt     := _Class;
  // Default problem: It's allocated, but not freed
  fProblem := [ pNotFreed ];
end;

function TAllocationInfo.ProblemCode: Char;
begin
  Result := chr( byte(fProblem) + ord('0') );
end;

function TAllocationInfo.ClassName: String;
begin
  if fType = vtClass then
    Result := TClass(fVmt).ClassName
  else
    Result := '';
end;

function TAllocationInfo.VmtPtr: Pointer;
begin
  if fType = vtObject then
    Result := fVmt
  else
    Result := nil;
end;

function TAllocationInfo.StringValue: PChar;
begin
  if fType = vtAnsiString then
    Result := PChar(fAddress) + 8 + StartOffset
  else
    Result := '';
end;


// ---------------------------------------------------------------------- \\
// -------[ TAllocationList: Managing allocations/deallocations ]-------- \\
// ---------------------------------------------------------------------- \\

function TAllocationList.Compare(Key1, Key2: Pointer): Integer;
begin
  Result := Longint(Key1) - Longint(Key2);
end;

function TAllocationList.KeyOf(Item: Pointer): Pointer;
begin
  Result := PAllocationInfo( Item )^.fAddress;
end;

procedure TAllocationList.NewAllocation( var _Address: Pointer; _Caller, _Object: Pointer; _Size: Longint );
var
  pItem: pAllocationInfo;
  Problem: TProblemInfo;
  FileName: String;
  LineNo: Longint;

begin
  inc( CurMemory, _Size );

  pItem := New( pAllocationInfo, Init( _Address, _Caller, _Object, _Size, MemMgrIndex ) );
  Insert( pItem );
  Problem.Init( MemMgrIndex, ' ' );

  if ProblemList.IndexOf( @Problem ) <> -1 then
    begin
      // On a previous run, this pointer was not freed
      if assigned( OnProblem ) then
        OnProblem( _Caller )
      else
        asm
          // Execution stops here, if the memory block being allocated
          // was not freed on a previous run.
          // To find the culprit, open a CPU window (View-VPU), and use
          // Goto (Ctrl-G) to go to the address held in _Caller. Then
          // hit Ctrl-Shift-V to see the associated source code.
          // It is often a good idea to use F4 (Run to cursor) at this
          // stage, after which the call stack can be inspected to
          // determine the cause of the memory Problem.
          int 3
        end;
    end;

  FillChar(_Address^, _Size, $CC);

{$IFNDEF HEAPCHK_MANUAL}
  PLongint(_Address)^ := heapchk_BufferBegin;
  PLongint(Longint(_Address) + _Size - StartOffset)^ := heapchk_BufferEnd;
  _Address := Pointer(Longint(_Address) + StartOffset);
{$ENDIF}

  // Remember max. number of blocks allocated
  if Count > MaxBlocks then
    MaxBlocks := Count;
  if CurMemory > MaxMemory then
    MaxMemory := CurMemory;

  inc( MemMgrIndex );
end;

procedure TAllocationList.FreeAllocation( var _Address: Pointer; var _Problems: TProbSet );
var
  Inx: Longint;
  Item: TAllocationInfo;
  pItem: PAllocationInfo;
  Size: Longint;
begin
{$IFNDEF HEAPCHK_MANUAL}
  _Address := Pointer(Longint(_Address) - StartOffset);
{$ENDIF}
  _Problems := [];
  Item.Init( _Address, nil, nil,  0, 0 );
  Inx := IndexOf( @Item );
  if Inx <> -1 then
    begin
      pItem := At( Inx );
      Size := PBlockRec( Longint(_Address) - SizeOf(TBlockRec) )^.Size;
      if abs(Size - pItem^.fSize) > 2*SizeOf(TBlockRec) then
        ErrorHandler( heap_SizeCorrupt, _Address );

{$IFNDEF HEAPCHK_MANUAL}
      if PLongint(_Address)^ <> heapchk_BufferBegin then
        begin
          ErrorHandler( heapchk_underrun, _Address );
          Include( pItem^.fProblem, pUnderrun );
        end;
      if PLongint(Longint(_Address) + pItem^.fSize - StartOffset)^ <> heapchk_BufferEnd then
        begin
          ErrorHandler( heapchk_overrun, _Address );
          Include( pItem^.fProblem, pOverrun );
        end;
{$ENDIF}

      Exclude( pItem^.fProblem, pNotFreed );
      dec( CurMemory, pItem^.fSize );
      FillChar( _Address^, pItem^.fSize, $AB );
      if pItem^.fProblem = [] then
        // Free the item if it was unproblematic, otherwise keep it
        // for reference
        AtFree( Inx )
      else
        _Problems := pItem^.fProblem;
    end
  else
    begin
{$IFNDEF HEAPCHK_MANUAL}
      // Maybe memory was allocated before HeapChk was installed;
      // adjust pointer accordingly
      _Address := Pointer(Longint(_Address) + StartOffset);
{$ENDIF}
      ErrorHandler( heap_freeinvalidmemory, _Address );
    end;
end;

// ---------------------------------------------------------------------- \\
// -------[ Implementation of actual memory manager interface ]---------- \\
// ---------------------------------------------------------------------- \\

const
  ReEntry : Longint = 0;          // Re-entry flag

var
  VPMemMan: TMemoryManager;       // Original VP memory manager

function IntCheckGetMem( _Size: Longint; _Caller, _Object: Pointer ): Pointer;
begin
{$IFNDEF HEAPCHK_MANUAL}
  if ReEntry = 0 then
    _Size := _Size + ExtraAlloc;  // Allocate 8 extra bytes for checking
{$ENDIF}
  Result := VPMemMan.GetMem(_Size); // Get memory
  if ReEntry = 0 then
    begin
      inc( ReEntry );
      AllocationList.NewAllocation( Result, _Caller, _Object, _Size );
      dec( ReEntry );
    end;
end;

// CheckGetMem is at the core of the heap checker.  When it receives control
// from the System unit's _MemNew function, it saves the return address
// and attempts to determine the real origin of the memory allocation
// request, which is passed on to IntCheckMem that does the actual
// allocation.

function CheckGetMem(Size: Longint): Pointer; assembler; {&uses none} {&frame-}
asm
        pop     eax              // Return address
        mov     edx,[SysVerified]
        test    edx,edx
        jz    @@NotObject        // System unit incorrect version

        mov     edx,[esp+$0c]    // Get real caller's address
        cmp     edx,OFFSET System.TObject.NewInstance
        jl      @@NotClass
        cmp     edx,OFFSET System.TObject.FreeInstance
        jge     @@NotClass
        mov     edx,[esp+$44]    // Constructing a class instance
        jmp     @@Go             // So class reference pointer in edx

      @@NotClass:
        cmp     edx,OFFSET System._ObjCtr
        jl      @@NotObject
        cmp     edx,OFFSET System._ObjDtr
        jge     @@NotObject
        mov     edx,[esp+$2c]    // Constructing an object instance
        or      ecx,1            // Mark as Object
        jmp     @@Go

      @@NotObject:
        cmp     edx,OFFSET System._LStrNew
        jl      @@Untyped
        cmp     edx,OFFSET System._LStrPacked
        jge     @@Untyped
        mov     ecx,2            // Mark as AnsiString
        jmp     @@Go

      @@Untyped:
        xor     ecx,ecx          // Not constructing a class or an object

      @@Go:
                                 // Param::0 - size - already on stack
        push    edx              // Param::1 - caller
        push    ecx              // Param::2 - TObject, if object
        push    eax              // Return address
        jmp     IntCheckGetMem
end;

function CheckFreeMem(P: Pointer): Longint;
var
  Problems: TProbSet;
begin
  if ReEntry = 0 then
    begin
      inc( ReEntry );
      AllocationList.FreeAllocation( P, Problems );
      dec( ReEntry );
    end
  else
    Problems := [];
  if Problems = [] then
    Result := VPMemMan.FreeMem(P);                // Free memory
end;

function CheckReallocMem(_P: Pointer; _Size: Longint): Pointer;
var
  Bytes : Longint;
begin
  // In order to avoid complications, implement ReAllocMem using
  // GetMem and FreeMem
  GetMem( Result, _Size );
  fillchar( Result^, _Size, 0 );

  Bytes := PBlockRec( Longint(_P) - SizeOf(TBlockRec) - StartOffset )^.Size;
  if Bytes > _Size then
    Bytes := _Size;
  move( _P^, Result^, Bytes );

  FreeMem( _P );
end;

// Verify that System unit is the one that low-level hacks rely on
// If not, disable getting of caller address

function VerifySystem: Boolean;

  function VerifyCallerAddress( _Caller: Pointer ): Boolean;
  begin
    // Verify that caller was from this vicinity
    Result := ( Longint(_Caller) > Longint(@VerifySystem) )
          and ( Longint(_Caller) < Longint(@InitHeapCheck) );
  end;

var
  pAlloc: pAllocationInfo;
  pObj: Objects.pObject;
  pCls: System.tObject;
  p: Pointer;

begin
  SysVerified := False;
  if PLongint(@_MemNew)^ = $448B5251 then
    begin
      // _MemNew is compiled correctly; assume True
      SysVerified := True;

      // Attempt to allocate memory and check
      GetMem(p, 10);
      pAlloc := PAllocationInfo( AllocationList.At(0) );
      SysVerified := ( PChar(pAlloc^.fAddress) + StartOffset = p )
                 and ( VerifyCallerAddress( pAlloc^.fCaller ) );
      FreeMem(p);

      // Attempt to allocate a class and check
      if SysVerified then
        begin
          pCls := Exception.Create( '' );
          pAlloc := PAllocationInfo( AllocationList.At(0) );
          SysVerified := ( pAlloc^.ClassName = 'Exception' )
                     and ( VerifyCallerAddress( pAlloc^.fCaller ) );
          pCls.Free;
        end;

      // Attempt to allocate an object and check
      if SysVerified then
        begin
          pObj := New(pStream, Init);
          pAlloc := PAllocationInfo( AllocationList.At(0) );
          SysVerified := ( pAlloc^.VmtPtr = typeof(tStream) )
                     and ( VerifyCallerAddress( pAlloc^.fCaller ) );
          Dispose(pObj, Done );
        end;
    end;
end;

// -------[ Exit procedure: Uninstall heap checker ]--------------------- \\

procedure HeapCheckExit;
begin
  SetMemoryManager(VPMemMan);          // Return to original mem mgr
  LogFile.ListProblems( AllocationList ); // Write list of problems to log file
  LogFile.Done;
  AllocationList.Done;                 // Free list of allocations
  ProblemList.Done;                    // Free list of problem records
end;

const
  HeapChecker: TMemoryManager = (
    GetMem: CheckGetMem;
    FreeMem: CheckFreeMem;
    ReallocMem: CheckReallocMem);

// ---------------------------------------------------------------------- \\
// -------[ Main entry point: activate heap checking ]------------------- \\
// ---------------------------------------------------------------------- \\

procedure InitHeapCheck( const _LogFile: String; _OnProblem: tOnProblem );
begin
  if HeapChkOn then                    // Prevent dual init!
    exit;
  HeapChkOn := True;

  LogFile.Init( _LogFile );            // Initialise the log file object
  LogFile.LoadProblems( ProblemList ); // Load list of problems, if available
  OnProblem := _OnProblem;             // Set user hook

  AllocationList.Init( 1000, 1000 );   // Initialise the allocation list
  GetMemoryManager(VPMemMan);          // Get the previous mem mgr
  SetMemoryManager(HeapChecker);       // - and install our own
  VerifySystem;                        // Verify the state of the System unit
  if not SysVerified then
    ErrorHandler( heapchk_system, nil );
  AddExitProc( HeapCheckExit );        // Make sure we terminate
end;

{$IFNDEF HEAPCHK_MANUAL}
initialization
  InitHeapCheck( '', nil );
{$ENDIF}
end.