 {
 ****************************************************************************
 CRW32 project
 Copyright (C) by Kuryakin Alexey, Sarov, Russia, 2001, <kouriakine@mail.ru>
 Memory allocation & addressing routines.
 Modifications:
 20010712 - Creation (uses CRW16) & test
 20011008 - adds for safety AllocErrorsCount, TInfoBlock.Anti & test (Ok)
 20011027 - SafeMove, SafeFillChar, Kill, Reallocate & test (Ok)
 20011028 - restructure, comments
 20011222 - TMasterObject
 20020206 - ExchangeVar
 20020302 - BornKillLog - look for object born - kill and log to file
 20030216 - TMasterObject->Exceptions,ErrorFound,ErrorReportProc,etc
 20030217 - GetAllocMemCount,GetAllocMemSize
 20030321 - Echo, SystemEchoProcedure
 20030322 - Struggle for safety (add some try/except checks)...
 20030328 - ResourceLeakageLogFile
 20030329 - ResourceLeakageLog,SafeFileWriteStr
 20041229 - Locked Integer manipulation derived from JCL (Jedi Code Library)
 20050224 - ObjectRegistry, move TLatch from _Fifo
 20120811 - BugReport
 20160927 - SendToMainConsole
 20171204 - BugReport modified
 20171206 - ENiceException,ESoftException,EEchoException,xxxQuotedStr
 20171216 - EHarmException,EFailException
 20200804 - PtrInt,PtrUint
 20211014 - IsENice/Soft/EchoException,ExtractHarmClass,FormatHarmlessBug
 ****************************************************************************
 }

unit _alloc; { allocation }

{$I _sysdef}

interface

uses
 {$IFDEF USES_SHAREMEM} ShareMem, {$ENDIF}
 sysutils, windows, classes, contnrs, math;

const
 CRLF = #13#10; // Text line delimiter

function GetAllocMemCount:Integer;
function GetAllocMemSize:Integer;

 {
 *******************************************************************************
 Object born / kill log for debug and test purpose
 *******************************************************************************
 }
const
 UsesBornKillLog : Boolean = false;
 UsesBornKillLogParamStr   = '-BornKillLog';
 BornKillLogFileName       = 'BORNKILL.LOG';
 ResourceLeakageLogFile    : ShortString = '';

procedure BornKillLog(const s:ShortString);
procedure ResourceLeakageLog(const s:ShortString);

 {
 *********************************************
 General purpose routines to work with memory.
 *********************************************
 IncPtr(Base,ByteOffset)     Return Base pointer incremented by ByteOffset bytes.
 DecPtr(Base,ByteOffset)     Return Base pointer decremented by ByteOffset bytes.
 SafeMove(Source,Dest,Count) Apply Move only if @Source<>nil,@Dest<>nil,Count>0.
 SafeFillChar(X,Count,Value) Apply FillChar only if @X<>nil,Count>0.
 AdjustBufferSize(Size,Step) Return Size, adjusted by Step module. For example:
                             AdjustBufferSize(0   ,4) = 0
                             AdjustBufferSize(1..4,4) = 4
                             AdjustBufferSize(5..8,4) = 8 & etc.
                             This function usefull to calculate buffer sizes.
 }
function  IncPtr(Base:Pointer; ByteOffset:LongInt):Pointer; register;
function  DecPtr(Base:Pointer; ByteOffset:LongInt):Pointer; register;
procedure SafeMove(const Source; var Dest; Count: LongInt);
procedure SafeFillChar(var X; Count: LongInt; Value: Byte); overload;
procedure SafeFillChar(var X; Count: LongInt; Value: Char); overload;
function  AdjustBufferSize(Size:LongInt; Step:LongInt):LongInt;

 {
 *************************************************************************
 General purpose routines to get/free memory and remember allocation size.
 *************************************************************************
 Allocate(N)             Allocate N bytes zero-filled memory block.
                         Return nil if N=0 or out of memory (no exceptions!).
                         Hidden information uses to remember the size of block.
                         To free block, use Deallocate function only!
 Deallocate(P)           Free memory block P after Allocate and set P to nil.
                         Use Deallocate(Pointer(P)) for typed pointers.
 AllocSize(P)            Check size of memory block P after Allocate.
 Reallocate(P,N)         Change allocated size of memory block P to new size N.
                         Data presents in P, will move to new memory block, tail
                         of block is zero-filled. If N=0, set P to nil.
 Notes:                  Allocate/Deallocate MUST uses in pair (as brakets).
                         After allocation user may check a size of block (AllocSize).
                         Using Allocate/Deallocate, exceptions, it seems, will
                         never occur, functions will return nil on fail.
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !!! Allocate/Deallocate is not compatible with GetMem/FreeMem   !!!
 !!! Never use FreeMem after Allocate or Deallocate after GetMem !!!
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 }
function  Allocate(N:LongInt):Pointer;
procedure Deallocate(var P:Pointer);
function  AllocSize(P:Pointer):LongInt;
function  Reallocate(var P:Pointer; N:LongInt):boolean;

 {
 **********************************************
 General purpose routines to work with objects.
 **********************************************
 Kill(TheObject)   That is same as FreeAndNil(TheObject), but with type checking
                   due to overloading. For any object class you may use call
                   Kill(TObject(TheObject)), but will be better to create
                   overloaded function Kill for this class and use call
                   Kill(TheObject). FreeAndNil have untyped parameter, that is
                   dangerous way. There are overload functions for some often
                   use classes.

 }
procedure Kill(var TheObject:TObject); overload;
procedure Kill(var TheObject:TList); overload;
procedure Kill(var TheObject:TThread); overload;
procedure Kill(var TheObject:TThreadList); overload;
procedure Kill(var TheObject:TObjectList); overload;
procedure Kill(var TheObject:TStringList); overload;
procedure Kill(var TheObject:TFileStream); overload;
procedure Kill(var TheObject:TMemoryStream); overload;

 {
 ***********************************************************************
 Multiplatform programming types
 see https://wiki.lazarus.freepascal.org/Multiplatform_Programming_Guide
 ***********************************************************************
 }
type
 PtrInt  = LongInt;  IntPtr  = PtrInt;  // Pointer-size   signed integer
 PtrUint = LongWord; UintPtr = PtrUint; // Pointer-size unsigned integer

type
 SizeInt = LongInt;  SizeUInt = LongWord; // Pointer-size (un)signed integer

 {
 *************************************
 General purpose constants and arrays.
 *************************************
 }
type
 TCharSet        = set of char;
 TByteSet        = set of byte;
 LongString      = AnsiString;

const
 KiloByte        = 1024;
 MegaByte        = KiloByte*KiloByte;

type
 PByte           = ^Byte;
 PShortInt       = ^ShortInt;
 PWord           = ^Word;
 PSmallInt       = ^SmallInt;
 PLongWord       = ^LongWord;
 PDWord          = ^DWord;
 PLongInt        = ^LongInt;
 PCardinal       = ^Cardinal;
 PInteger        = ^Integer;
 PInt64          = ^Int64;
 PSingle         = ^Single;
 PDouble         = ^Double;
 PComp           = ^Comp;
 PExtended       = ^Extended;

const
 MaxNumByte      = MaxInt;
 MaxNumChar      = MaxNumByte div sizeof(Char);
 MaxNumShortInt  = MaxNumByte div sizeof(ShortInt);
 MaxNumBoolean   = MaxNumByte div sizeof(Boolean);
 MaxNumWord      = MaxNumByte div sizeof(Word);
 MaxNumSmallInt  = MaxNumByte div sizeof(SmallInt);
 MaxNumLongWord  = MaxNumByte div sizeof(LongWord);
 MaxNumDWord     = MaxNumByte div sizeof(DWord);
 MaxNumLongInt   = MaxNumByte div sizeof(LongInt);
 MaxNumCardinal  = MaxNumByte div sizeof(Cardinal);
 MaxNumInteger   = MaxNumByte div sizeof(Integer);
 MaxNumInt64     = MaxNumByte div sizeof(Int64);
 MaxNumSingle    = MaxNumByte div sizeof(Single);
 MaxNumDouble    = MaxNumByte div sizeof(Double);
 MaxNumComp      = MaxNumByte div sizeof(Comp);
 MaxNumExtended  = MaxNumByte div sizeof(Extended);
 MaxNumPointer   = MaxNumByte div sizeof(Pointer);

type
 TByteArray      = packed array[0..MaxNumByte-1]     of Byte;
 TCharArray      = packed array[0..MaxNumChar-1]     of Char;
 TShortIntArray  = packed array[0..MaxNumShortInt-1] of ShortInt;
 TBooleanArray   = packed array[0..MaxNumBoolean-1]  of Boolean;
 TWordArray      = packed array[0..MaxNumWord-1]     of Word;
 TSmallIntArray  = packed array[0..MaxNumSmallInt-1] of SmallInt;
 TLongWordArray  = packed array[0..MaxNumLongWord-1] of LongWord;
 TDWordArray     = packed array[0..MaxNumDWord-1]    of DWord;
 TLongIntArray   = packed array[0..MaxNumLongInt-1]  of LongInt;
 TCardinalArray  = packed array[0..MaxNumCardinal-1] of Cardinal;
 TIntegerArray   = packed array[0..MaxNumInteger-1]  of Integer;
 TInt64Array     = packed array[0..MaxNumInt64-1]    of Int64;
 TSingleArray    = packed array[0..MaxNumSingle-1]   of Single;
 TDoubleArray    = packed array[0..MaxNumDouble-1]   of Double;
 TCompArray      = packed array[0..MaxNumComp-1]     of Comp;
 TExtendedArray  = packed array[0..MaxNumExtended-1] of Extended;
 TPointerArray   = packed array[0..MaxNumPointer-1]  of Pointer;

type
 PByteArray      = ^TByteArray;
 PShortIntArray  = ^TShortIntArray;
 PBooleanArray   = ^TBooleanArray;
 PWordArray      = ^TWordArray;
 PSmallIntArray  = ^TSmallIntArray;
 PLongWordArray  = ^TLongWordArray;
 PDWordArray     = ^TDWordArray;
 PLongIntArray   = ^TLongIntArray;
 PCardinalArray  = ^TCardinalArray;
 PIntegerArray   = ^TIntegerArray;
 PInt64Array     = ^TInt64Array;
 PSingleArray    = ^TSingleArray;
 PDoubleArray    = ^TDoubleArray;
 PCompArray      = ^TCompArray;
 PExtendedArray  = ^TExtendedArray;
 PPointerArray   = ^TPointerArray;

 {
 *******************************************************************************
 Exchange variables routines.
 procedure ExchangeVar(a,b:Type);
 var Temp:Type;
 begin
  Temp:=a; a:=b; b:=Temp;
 end;
 *******************************************************************************
 }
procedure ExchangeVar(var a,b:Char); overload;
procedure ExchangeVar(var a,b:Byte); overload;
procedure ExchangeVar(var a,b:ShortInt); overload;
procedure ExchangeVar(var a,b:Word); overload;
procedure ExchangeVar(var a,b:SmallInt); overload;
procedure ExchangeVar(var a,b:LongWord); overload;
procedure ExchangeVar(var a,b:LongInt); overload;
procedure ExchangeVar(var a,b:Int64); overload;
procedure ExchangeVar(var a,b:Single); overload;
procedure ExchangeVar(var a,b:Double); overload;
procedure ExchangeVar(var a,b:Comp); overload;
procedure ExchangeVar(var a,b:Extended); overload;
procedure ExchangeVar(var a,b:ShortString); overload;
procedure ExchangeVar(var a,b:LongString); overload;

 {
 ***************************************
 Exception classes for various purposes.
 ***************************************
 }
type
 ENiceException = class(Exception);       // Harmless exceptions which is not requires panic reaction
 ESoftException = class(ENiceException);  // Harmless exceptions to be used by software for convenience
 EEchoException = class(ESoftException);  // Harmless exceptions which imply Echo only but not warnings
 EHideException = class(ESoftException);  // Harmless exceptions which don`t need no warnings or echo
 EHarmException = class(Exception);       // Harmful  exceptions which requires log/warning/alarm etc
 EFailException = class(EHarmException);  // Harmful  exceptions in case of hardware/software failure

function IsHarmlessException(E:Exception; const HarmClass:LongString=''):Boolean; // Is E classified as harmless?
function IsENiceException(E:Exception; const HarmClass:LongString=''):Boolean;    // E or HarmClass is ENiceException
function IsESoftException(E:Exception; const HarmClass:LongString=''):Boolean;    // E or HarmClass is ESoftException
function IsEEchoException(E:Exception; const HarmClass:LongString=''):Boolean;    // E or HarmClass is EEchoException
function IsEHideException(E:Exception; const HarmClass:LongString=''):Boolean;    // E or HarmClass is EHideException

type                                      // User to make reports on exceptions
 TBugReportProc = procedure(E:Exception; Sender:TObject; Note:LongString);

 ////////////////////////////////////////////////////////////////////////////////////////////////////
 // FormatHarmlessBug formats Note message for BugReport to handle exception as harmless with class C
 // For example: on E:Exception do BugReport(E,nil,FormatHarmlessBug(ESoftException,'Error found.'));
 ////////////////////////////////////////////////////////////////////////////////////////////////////
function FormatHarmlessBug(C:TClass; const Msg:LongString):LongString;
function ExtractHarmClass(var Note:LongString):LongString;

 {
 *********************************************
 Basic class for classes with Master property.
 *********************************************
 Master property is pointer to static variable, wich points to object.
 TMasterObject clears this variable to nil in destructor, so we may be sure
 that this variable always have correct value.
 Example:
  x:=TMasterObject.Create;
  x.Master:=x;
  ...
  x.Free;          // automatically set variable x to nil
  ...
  if x.Ok then ... // check object valid
 }
type
 EMasterObject = class(ESoftException);
 TMasterObject = class(TObject)
 private
  myRef      : Integer;
  myMaster   : ^TMasterObject;
  myExcepts  : Boolean;
  myReporter : TBugReportProc;
  function    GetOk:Boolean;
  function    GetRef:Integer;
  function    GetExceptions:Boolean;
  procedure   SetExceptions(aExcepts:Boolean);
  procedure   SetErrorReportProc(const aProc:TBugReportProc);
 protected
  function    CheckOk:Boolean; virtual;
  procedure   SetupMaster(var aMaster:TMasterObject);
  procedure   ClearMaster;
  procedure   ErrorFound(E:Exception; const Note:LongString=''); virtual;
  procedure   ErrorReport(E:Exception; const Note:LongString='');
 public
  constructor Create;
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
 public
  property    Ok              : Boolean        read  GetOk;
  property    Ref             : Integer        read  GetRef;
  property    Master          : TMasterObject  write SetupMaster;
  property    Exceptions      : Boolean        read  GetExceptions write SetExceptions;
  property    ErrorReportProc : TBugReportProc write SetErrorReportProc;
 end;

procedure DefaultObjectErrorReportProc(E:Exception; Sender:TObject; Note:LongString);

 {
 TLatch incapsulate Windows critical sections in multithread applications.
 }
type
 TLatch = class(TMasterObject)
 private
  myLatch   : TRTLCriticalSection;
 public
  constructor Create;
  destructor  Destroy; override;
  {
  Locks object, enter critical section.
  Uses to protect object from other threads.
  Lock/Unlock MUST be called as "brackets" of critical section.
  }
  procedure   Lock;
  {
  Unlocks object after lock, leave critical section.
  Lock/Unlock MUST be called as "brackets" of critical section.
  }
  procedure   UnLock;
 end;

 {
 General creation/destruction latch functions.
 }
function  NewLatch:TLatch;
procedure Kill(var TheObject:TLatch); overload;

 {
 ***************************************************
 TObjectRegistry is a storage for TObject references
 ***************************************************
 }
const
 ObjectRegistryOffset = $100000;
type
 EObjectRegistry = class(ESoftException);
 TObjectRegistryAction = procedure(Ref:Integer;Obj:TObject;var Terminate:Boolean;Custom:Pointer);
 TObjectRegistry = class(TLatch)
 private
  myTable : PPointerArray;
  myStack : PIntegerArray;
  myCount : Integer;
  mySpace : Integer;
  myCapac : Integer;
  function GetCount:Integer;
  function GetSpace:Integer;
  function GetCapacity:Integer;
  function GetItems(Ref:Integer):TObject;
 public
  constructor Create;
  destructor  Destroy; override;
  function    InitRef(Obj:TObject):Integer;
  function    FreeRef(Ref:Integer):Boolean;
  procedure   ForEach(Action:TObjectRegistryAction; Custom:Pointer=nil);
  function    ClassNameList:String;
 public
  property Count            : Integer read GetCount;
  property Space            : Integer read GetSpace;
  property Capacity         : Integer read GetCapacity;
  property Items[i:Integer] : TObject read GetItems; default;
 end;

 {
 *****************************************************
 ObjectRegistry contains ALL TMasterObject references.
 So you may use Object.Ref as unique handle of Object.
  Ref:=TSomeObject.Create.Ref;
  (ObjectRegistry[Ref] as TSomeObject).DoSomething;
 *****************************************************
 }
function ObjectRegistry:TObjectRegistry;

 {
 *******************************************************************************
 Echo procedure uses to thread safety write messages to console/file etc.
 *******************************************************************************
 }
procedure Echo(const Msg:LongString; const LineBreak:LongString=CRLF);

type
 TEchoProcedure = procedure(const Msg:LongString);

const
 SystemEchoProcedure : TEchoProcedure = nil;

 {
 *******************************************************************************
 SendToMainConsole procedure uses to thread safety send messages to main console.
 *******************************************************************************
 }
function SendToMainConsole(const Msg:LongString):Integer;

const
 SystemSendToMainConsoleFunction : function(const Msg:LongString):Integer = nil;

 {
 *******************************************************************************
 Utilities for string manipulation.
 *******************************************************************************
 }
function SingleQuotedStr(const S:LongString):LongString;        // 'S'
function DoubleQuotedStr(const S:LongString):LongString;        // "S"
function DoubleAngleQuotedStr(const S:LongString):LongString;   // «S»

 {
 *******************************************************************************
 Procedure uses to print report on exceptions.
 Usage is like: try ..  except on E:Exeption do BugReport(E); end;
 *******************************************************************************
 }
procedure BugReport(E:Exception; Sender:TObject=nil; Note:LongString='');

 {
 *******************************************************************************
 SafeFileWriteStr procedure uses to thread/bug safety write messages to file.
 *******************************************************************************
 }
procedure SafeFileWriteStr(const FileName:ShortString; const Msg:LongString;
                           const LineBreak:LongString=CRLF);

 {
 *******************************************************************************
 Locked Integer manipulation derived from JCL (Jedi Code Library).
 Routines to manipulate simple typed variables in a thread safe manner.
 That is simplest and fastest way for thread and process synchronization.
   |----------------------|-----------------------|----------------|
   |Operation             | new value of Target   | Result         |
   |----------------------|-----------------------|----------------|
   |LockedAdd             | Target + Value        | Target + Value |
   |LockedSub             | Target - Value        | Target - Value |
   |LockedInc             | Target + 1            | Target + 1     |
   |LockedDec             | Target - 1            | Target - 1     |
   |LockedExchange        | Value                 | Target         |
   |LockedExchangeAdd     | Target + Value        | Target         |
   |LockedExchangeSub     | Target - Value        | Target         |
   |LockedExchangeInc     | Target + 1            | Target         |
   |LockedExchangeDec     | Target - 1            | Target         |
   |LockedCompareExchange | if Target=Comp        | Target         |
   |                      | then Exch else Target | Target         |
   |----------------------|-----------------------|----------------|
 Notes:
 1) Target variable address must be 32-bit aligned.
 2) Based on i486 and higher assembler, not available on i386.
 3) Locked/Add/Sub/Inc/Dec return result of operation, i.e. new value of Target.
 4) LockedExchange/Add/Sub/Inc/Dec return original Target, i.e. before operation.
 *******************************************************************************
 }
function LockedAdd(var Target: Integer; Value: Integer): Integer;
function LockedCompareExchange(var Target: Integer; Exch, Comp: Integer): Integer; overload;
function LockedCompareExchange(var Target: Pointer; Exch, Comp: Pointer): Pointer; overload;
function LockedDec(var Target: Integer): Integer;
function LockedExchange(var Target: Integer; Value: Integer): Integer;
function LockedExchangeAdd(var Target: Integer; Value: Integer): Integer;
function LockedExchangeDec(var Target: Integer): Integer;
function LockedExchangeInc(var Target: Integer): Integer;
function LockedExchangeSub(var Target: Integer; Value: Integer): Integer;
function LockedInc(var Target: Integer): Integer;
function LockedSub(var Target: Integer; Value: Integer): Integer;

implementation

function GetAllocMemCount:Integer;
begin
 {$IFDEF USES_SHAREMEM}
 Result:=ShareMem.GetAllocMemCount;
 {$ELSE}
 Result:=System.AllocMemCount;
 {$ENDIF}
end;

function GetAllocMemSize:Integer;
begin
 {$IFDEF USES_SHAREMEM}
 Result:=ShareMem.GetAllocMemSize;
 {$ELSE}
 Result:=System.AllocMemSize;
 {$ENDIF}
end;

 {
 *******************************************************************************
 Object born / kill log for debug and test purpose
 *******************************************************************************
 }
const
 AllocMemBalance  : LongInt     = 0;
 AllocateBalance  : LongInt     = 0;
 BornKillBalance  : LongInt     = 0;
 AllocErrorCount  : LongInt     = 0;
 BornKillFile     : ShortString = '';

procedure BornKillLog(const s:ShortString);
begin
 if UsesBornKillLog then SafeFileWriteStr(BornKillFile,s);
end;

procedure  ResourceLeakageLog(const s:ShortString);
begin
 if Length(ResourceLeakageLogFile)>0
 then SafeFileWriteStr(ResourceLeakageLogFile,s);
end;

procedure InitBornKillLog;
var
 i : Integer;
begin
 AllocMemBalance:=GetAllocMemSize;
 BornKillFile:=SysUtils.ExtractFilePath(ParamStr(0))+BornKillLogFileName;
 SysUtils.DeleteFile(BornKillFile);
 UsesBornKillLog:=false;
 for i:=1 to ParamCount do
 if AnsiCompareText(ParamStr(i),UsesBornKillLogParamStr)=0 then begin
  UsesBornKillLog:=true;
  Break;
 end;
end;

procedure DoneBornKillLog;
begin
 AllocMemBalance:=GetAllocMemSize-AllocMemBalance;
 BornKillLog(Format('AllocMem balance = %d',[AllocMemBalance]));
 BornKillLog(Format('BornKill balance = %d',[BornKillBalance]));
 BornKillLog(Format('Allocate balance = %d',[AllocateBalance]));
 BornKillLog(Format('AllocErrorsCount = %d',[AllocErrorCount]));
 ResourceLeakageLog(Format('%-60s = %d',['Balance of GetMem/FreeMem',          AllocMemBalance]));
 ResourceLeakageLog(Format('%-60s = %d',['Balance of TMasterObject.Born/Kill', BornKillBalance]));
 ResourceLeakageLog(Format('%-60s = %d',['Balance of Allocate/Deallocate',     AllocateBalance]));
 ResourceLeakageLog(Format('%-60s = %d',['Allocate/Deallocate Errors Count',   AllocErrorCount]));
end;

 {
 *********************************************
 General purpose routines to work with memory.
 *********************************************
 }

function IncPtr(Base:Pointer; ByteOffset:LongInt):Pointer; register;
asm
 ADD EAX,EDX
end;

function DecPtr(Base:Pointer; ByteOffset:LongInt):Pointer; register;
asm
 SUB EAX,EDX
end;

procedure SafeMove(const Source; var Dest; Count: LongInt);
begin
 if (Count>0) and (@Source<>nil) and (@Dest<>nil) then Move(Source,Dest,Count);
end;

procedure SafeFillChar(var X; Count: LongInt; Value: Byte); overload;
begin
 if (Count>0) and (@X<>nil) then FillChar(X,Count,Value);
end;

procedure SafeFillChar(var X; Count: LongInt; Value: Char); overload;
begin
 if (Count>0) and (@X<>nil) then FillChar(X,Count,Value);
end;

function  AdjustBufferSize(Size:LongInt; Step:LongInt):LongInt;
begin
 if Size<0 then Size:=0;
 if Step<1 then Step:=1;
 Result:=Max(Size,((Size+Step-1) div Step)*Step);
end;

 {
 *************************************************************************
 General purpose routines to get/free memory and remember allocation size.
 *************************************************************************
 }

type
 TInfoBlock = packed record
  TheSize   : LongInt;
  NotSize   : LongInt;
  TheData   : packed record end;
 end;

function myMemAlloc(Size:LongInt):Pointer;
begin
 Result:=nil;
 if Size>0 then
 try
  GetMem(Result,Size);
  SafeFillChar(Result^,Size,0);
  LockedAdd(AllocateBalance,Size);
 except
  on E:Exception do begin
   LockedInc(AllocErrorCount);
   BugReport(E);
   Result:=nil;
  end;
 end;
end;

procedure myMemFree(P:Pointer; Size:LongInt);
begin
 if Assigned(P) then
 try
  FreeMem(P,Size);
  LockedSub(AllocateBalance,Size);
 except
  on E:Exception do begin
   LockedInc(AllocErrorCount);
   BugReport(E);
  end;
 end;
end;

function Allocate(N:LongInt):Pointer;
begin
 Result:=nil;
 if N>0 then
 try
  Result:=myMemAlloc(N+SizeOf(TInfoBlock));
  if Assigned(Result) then begin
   with TInfoBlock(Result^) do begin
    TheSize:=N;
    NotSize:=not TheSize;
   end;
   Result:=IncPtr(Result,SizeOf(TInfoBlock));
  end;
 except
  on E:Exception do begin
   LockedInc(AllocErrorCount);
   BugReport(E);
  end;
 end;
end;

procedure Deallocate(var P:Pointer);
var PP:Pointer;
begin
 if Assigned(P) then
 try
  PP:=DecPtr(P,SizeOf(TInfoBlock));
  P:=nil;
  if Assigned(PP) then with TInfoBlock(PP^) do begin
   if TheSize = not NotSize
   then myMemFree(PP,TheSize+SizeOf(TInfoBlock))
   else LockedInc(AllocErrorCount);
  end else LockedInc(AllocErrorCount);
 except
  on E:Exception do begin
   LockedInc(AllocErrorCount);
   BugReport(E);
  end;
 end;
end;

function AllocSize(P:Pointer):LongInt;
begin
 Result:=0;
 if Assigned(P) then
 try 
  P:=DecPtr(P,SizeOf(TInfoBlock));
  if Assigned(P) then with TInfoBlock(P^) do begin
   if TheSize =  not NotSize
   then Result:=TheSize
   else LockedInc(AllocErrorCount);
  end else LockedInc(AllocErrorCount);
 except
  on E:Exception do begin
   LockedInc(AllocErrorCount);
   BugReport(E);
  end;
 end;
end;

function Reallocate(var P:Pointer; N:LongInt):Boolean;
var OldData,NewData:Pointer; OldSize,NewSize:LongInt;
begin
 Result:=false;
 try
  OldData:=P;
  OldSize:=AllocSize(OldData);
  NewSize:=Max(0,N);
  if OldSize=NewSize then Result:=true else begin
   NewData:=Allocate(NewSize);
   if AllocSize(NewData)=NewSize then begin
    SafeMove(OldData^,NewData^,Min(OldSize,NewSize));
    P:=NewData;
    Deallocate(OldData);
    Result:=true;
   end else begin
    Deallocate(NewData);
    LockedInc(AllocErrorCount);
   end;
  end;
 except
  on E:Exception do begin
   LockedInc(AllocErrorCount);
   BugReport(E);
  end;
 end;
end;

 {
 **********************************************
 General purpose routines to work with objects.
 **********************************************
 }

procedure Kill(var TheObject:TObject); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end; 
end;

procedure Kill(var TheObject:TList); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end; 
end;

procedure Kill(var TheObject:TThread); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end;
end;

procedure Kill(var TheObject:TThreadList); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end;
end;

procedure Kill(var TheObject:TObjectList); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end;
end;

procedure Kill(var TheObject:TStringList); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end; 
end;

procedure Kill(var TheObject:TFileStream); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end; 
end;

procedure Kill(var TheObject:TMemoryStream); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end; 
end;

 {
 *******************************************************************************
 Exchange variables implementation.
 *******************************************************************************
 }
procedure ExchangeVar(var a,b:Char); overload;
var Temp:Char;
begin
 Temp:=a; a:=b; b:=Temp;
end;

procedure ExchangeVar(var a,b:Byte); overload;
var Temp:Byte;
begin
 Temp:=a; a:=b; b:=Temp;
end;

procedure ExchangeVar(var a,b:ShortInt); overload;
var Temp:ShortInt;
begin
 Temp:=a; a:=b; b:=Temp;
end;

procedure ExchangeVar(var a,b:Word); overload;
var Temp:Word;
begin
 Temp:=a; a:=b; b:=Temp;
end;

procedure ExchangeVar(var a,b:SmallInt); overload;
var Temp:SmallInt;
begin
 Temp:=a; a:=b; b:=Temp;
end;

procedure ExchangeVar(var a,b:LongWord); overload;
var Temp:LongWord;
begin
 Temp:=a; a:=b; b:=Temp;
end;

procedure ExchangeVar(var a,b:LongInt); overload;
var Temp:LongInt;
begin
 Temp:=a; a:=b; b:=Temp;
end;

procedure ExchangeVar(var a,b:Int64); overload;
var Temp:Int64;
begin
 Temp:=a; a:=b; b:=Temp;
end;

procedure ExchangeVar(var a,b:Single); overload;
var Temp:Single;
begin
 Temp:=a; a:=b; b:=Temp;
end;

procedure ExchangeVar(var a,b:Double); overload;
var Temp:Double;
begin
 Temp:=a; a:=b; b:=Temp;
end;

procedure ExchangeVar(var a,b:Comp); overload;
var Temp:Comp;
begin
 Temp:=a; a:=b; b:=Temp;
end;

procedure ExchangeVar(var a,b:Extended); overload;
var Temp:Extended;
begin
 Temp:=a; a:=b; b:=Temp;
end;

procedure ExchangeVar(var a,b:ShortString); overload;
var Temp:ShortString;
begin
 Temp:=a; a:=b; b:=Temp;
end;

procedure ExchangeVar(var a,b:LongString); overload;
var Temp:LongString;
begin
 Temp:=a; a:=b; b:=Temp;
 Temp:='';
end;

 {
 ****************************
 TMasterObject implementation
 ****************************
 }
constructor TMasterObject.Create;
begin
 inherited Create;
 myMaster:=nil;
 myExcepts:=false;
 myReporter:=DefaultObjectErrorReportProc;
end;

procedure TMasterObject.AfterConstruction;
begin
 inherited AfterConstruction;
 if UsesBornKillLog
 then BornKillLog(Format('BORN %-25s %8.8x %8.8x %d',
                  [ClassName, Integer(Self), GetCurrentThreadID, BornKillBalance]));
 LockedInc(BornKillBalance);
 myRef:=ObjectRegistry.InitRef(Self);
end;

procedure TMasterObject.BeforeDestruction;
begin
 ObjectRegistry.FreeRef(myRef);
 LockedDec(BornKillBalance);
 if UsesBornKillLog
 then BornKillLog(Format('KILL %-25s %8.8x %8.8x %d',
                  [ClassName, Integer(Self), GetCurrentThreadID, BornKillBalance]));
 ClearMaster;
 inherited BeforeDestruction;
end;

function TMasterObject.GetOk:Boolean;
begin
 if Assigned(Self) then Result:=CheckOk else Result:=false;
end;

function TMasterObject.GetRef:Integer;
begin
 if Assigned(Self) then Result:=myRef else Result:=0;
end;

function TMasterObject.CheckOk:Boolean;
begin
 Result:=true;
end;

procedure TMasterObject.SetupMaster(var aMaster:TMasterObject);
begin
 if Assigned(Self) then begin
  if aMaster=Self then myMaster:=@aMaster else myMaster:=nil;
 end;
end;

procedure TMasterObject.ClearMaster;
begin
 if Assigned(Self) then begin
  if Assigned(myMaster) then if myMaster^=Self then myMaster^:=nil;
  myMaster:=nil;
 end;
end;

function TMasterObject.GetExceptions:Boolean;
begin
 if Assigned(Self) then Result:=myExcepts else Result:=false;
end;

procedure TMasterObject.SetExceptions(aExcepts:Boolean);
begin
 if Assigned(Self) then myExcepts:=aExcepts;
end;

procedure TMasterObject.ErrorFound(E:Exception; const Note:LongString);
begin
 if Exceptions then begin
  if E is Exception
  then RAISE EMasterObject.Create(E.Message)
  else RAISE EMasterObject.Create(Note)
 end else ErrorReport(E,Note);
end;

procedure TMasterObject.SetErrorReportProc(const aProc:TBugReportProc);
begin
 if Assigned(Self) then myReporter:=aProc;
end;

procedure TMasterObject.ErrorReport(E:Exception; const Note:LongString);
begin
 if Assigned(Self) and Assigned(myReporter)
 then myReporter(E,Self,Note)
 else BugReport(E,Self,Note);
end;

procedure DefaultObjectErrorReportProc(E:Exception; Sender:TObject; Note:LongString);
begin
 if E is Exception then BugReport(E,Sender,Note) else
 if Assigned(Sender) then if Note<>'' then Echo(Note);
end;

 {
 *********************
 TLatch implementation
 *********************
 }
const
 LockUnlockBalance : LongInt = 0;

constructor TLatch.Create;
begin
 inherited Create;
 InitializeCriticalSection(myLatch);
end;

destructor TLatch.Destroy;
begin
 DeleteCriticalSection(myLatch);
 inherited Destroy;
end;

procedure TLatch.Lock;
begin
 if Assigned(Self) then begin
  EnterCriticalSection(myLatch);
  LockedInc(LockUnlockBalance);
 end;
end;

procedure TLatch.Unlock;
begin
 if Assigned(Self) then begin
  LockedDec(LockUnlockBalance);
  LeaveCriticalSection(myLatch);
 end;
end;

function  NewLatch:TLatch;
begin
 Result:=nil;
 try
  Result:=TLatch.Create;
 except
  on E:Exception do BugReport(E);
 end;
end;

procedure Kill(var TheObject:TLatch); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end;
end;

 {
 ******************************
 TObjectRegistry implementation
 ******************************
 }
const
 TheObjectRegistry : TObjectRegistry = nil;
 ErrObjectRegistry : Integer         = 0;

function ObjectRegistry:TObjectRegistry;
begin
 Result:=TheObjectRegistry;
end;

procedure ObjectRegistryErrorReportProc(E:Exception; Sender:TObject; Note:LongString);
begin
 if Assigned(Sender) then LockedInc(ErrObjectRegistry);
 DefaultObjectErrorReportProc(E,Sender,Note);
end;

constructor TObjectRegistry.Create;
begin
 inherited;
 ErrorReportProc:=ObjectRegistryErrorReportProc;
 myTable:=nil;
 myStack:=nil;
 myCount:=0;
 mySpace:=0;
 myCapac:=0;
end;

destructor TObjectRegistry.Destroy;
begin
 Lock;
 try
  Deallocate(Pointer(myTable));
  Deallocate(Pointer(myStack));
  myCapac:=0;
  myCount:=0;
  mySpace:=0;
 finally
  Unlock;
 end;
 inherited;
end;

function TObjectRegistry.GetCount:Integer;
begin
 Result:=0;
 if Assigned(Self) then begin
  Lock;
  Result:=myCount;
  Unlock;
 end;
end;

function TObjectRegistry.GetSpace:Integer;
begin
 Result:=0;
 if Assigned(Self) then begin
  Lock;
  Result:=mySpace;
  Unlock;
 end;
end;

function TObjectRegistry.GetCapacity:Integer;
begin
 Result:=0;
 if Assigned(Self) then begin
  Lock;
  Result:=myCapac;
  Unlock;
 end;
end;

function TObjectRegistry.GetItems(Ref:Integer):TObject;
begin
 Result:=nil;
 if Assigned(Self) then begin
  Lock;
  Dec(Ref,ObjectRegistryOffset);
  if Cardinal(Ref)<Cardinal(myCapac) then Result:=myTable[Ref];
  Unlock;
 end;
end;

function TObjectRegistry.InitRef(Obj:TObject):Integer;
var
 i : Integer;
begin
 Result:=0;
 if Assigned(Obj) then
 if Assigned(Self) then
 try
  Lock;
  try
   if mySpace=0 then begin
    if myCapac=0 then begin
     if not Reallocate(Pointer(myTable),SizeOf(myTable[0]))
     or not Reallocate(Pointer(myStack),SizeOf(myStack[0]))
     then RAISE EObjectRegistry.Create('Out of memory!');
     myTable[0]:=nil;
     myStack[0]:=0;
     Inc(myCapac);
     Inc(mySpace);
    end else begin
     if not Reallocate(Pointer(myTable),2*myCapac*SizeOf(myTable[0]))
     or not Reallocate(Pointer(myStack),2*myCapac*SizeOf(myStack[0]))
     then RAISE EObjectRegistry.Create('Out of memory!');
     for i:=myCapac to 2*myCapac-1 do begin
      myStack[mySpace]:=i;
      myTable[i]:=nil;
      Inc(mySpace);
     end;
     Inc(myCapac,myCapac);
    end;
   end;
   i:=myStack[mySpace-1];
   if (Cardinal(i)>=Cardinal(myCapac)) or Assigned(myTable[i])
   then RAISE EObjectRegistry.Create('InitRef Error!');
   myTable[i]:=Obj;
   Dec(mySpace);
   Inc(myCount);
   if Items[i+ObjectRegistryOffset]<>Obj
   then RAISE EObjectRegistry.Create('InitRef Error!');
   Result:=i+ObjectRegistryOffset;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorReport(E);
 end;
end;

function TObjectRegistry.FreeRef(Ref:Integer):Boolean;
begin
 Result:=false;
 if Ref<>0 then
 if Assigned(Self) then
 try
  Lock;
  try
   Dec(Ref,ObjectRegistryOffset);
   if (Cardinal(Ref)<Cardinal(myCapac)) and Assigned(myTable[Ref]) then begin
    myTable[Ref]:=nil;
    Dec(myCount);
    if mySpace>=myCapac then RAISE EObjectRegistry.Create('FreeRef Error!');
    myStack[mySpace]:=Ref;
    Inc(mySpace);
    Result:=true;
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorReport(E);
 end;
end;

procedure TObjectRegistry.ForEach(Action:TObjectRegistryAction; Custom:Pointer=nil);
var
 i         : Integer;
 Terminate : Boolean;
begin
 if Assigned(Self) then
 if Assigned(Action) then
 try
  Lock;
  try
   Terminate:=false;
   for i:=0 to myCapac-1 do
   if Assigned(myTable[i]) then begin
    Action(i+ObjectRegistryOffset,myTable[i],Terminate,Custom);
    if Terminate then Break;
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorReport(E);
 end;
end;

procedure ClassNameListCallback(Ref:Integer;Obj:TObject;var Terminate:Boolean;Custom:Pointer);
begin
 if (Obj<>nil) and (Custom<>nil) then TStringList(Custom).Add(Obj.ClassName);
end;

function TObjectRegistry.ClassNameList:String;
var Lines:TStringList;
begin
 Result:='';
 if Count=0 then Exit;
 Lines:=TStringList.Create;
 try
  ForEach(ClassNameListCallback,Lines);
  Result:=StringReplace(SysUtils.Trim(Lines.Text),#13#10,',',[rfReplaceAll]);
 finally
  Lines.Free;
 end;
end;

procedure Echo(const Msg:LongString; const LineBreak:LongString=CRLF);
begin
 if Assigned(SystemEchoProcedure) then
 try
  SystemEchoProcedure(Msg+LineBreak);
 except
 end;
end;

function SendToMainConsole(const Msg:LongString):Integer;
begin
 Result:=0;
 if Length(Msg)>0 then
 if Assigned(SystemSendToMainConsoleFunction) then
 try
  Result:=SystemSendToMainConsoleFunction(Msg)
 except
  on E:Exception do BugReport(E);
 end;
end;

function SingleQuotedStr(const S:LongString):LongString;        begin Result:=''''+S+''''; end;
function DoubleQuotedStr(const S:LongString):LongString;        begin Result:='"'+S+'"'; end;
function DoubleAngleQuotedStr(const S:LongString):LongString;   begin Result:='«'+S+'»'; end;

function ExceptionInfoFilter(Info:LongString):LongString;
begin
 Result:=SysUtils.Trim(Info); // See SysConst unit
 if (Pos('Exception ',Result)=1) then Result:=Copy(Result,11,Length(Result)-10);
 if (Result<>'') and (Result[Length(Result)]='.') then Result:=Copy(Result,1,Length(Result)-1);
 Result:=StringReplace(Result,'Cannot access package information for package ','Fail package ',[rfReplaceAll]);
 Result:=StringReplace(Result,'Access violation ','Violation ',[rfReplaceAll]);
 Result:=StringReplace(Result,' is not a valid ',' is bad ',[rfReplaceAll]);
 Result:=StringReplace(Result,' floating point ',' float ',[rfReplaceAll]);
 Result:=StringReplace(Result,'Floating point ','Float ',[rfReplaceAll]);
 Result:=StringReplace(Result,' of address ',' of ',[rfReplaceAll]);
 Result:=StringReplace(Result,' at address ',' at ',[rfReplaceAll]);
 Result:=StringReplace(Result,' in module ',' in ',[rfReplaceAll]);
 Result:=StringReplace(Result,'Invalid ','Bad ',[rfReplaceAll]);
 Result:=StringReplace(Result,'.'+CRLF,' «',[]);
 Result:=StringReplace(Result,'.'#10,' «',[]);
 if Pos('«',Result)>0 then Result:=Result+'»';
end;

function GetExceptionInfo(ExceptObject:TObject; ExceptAddr:Pointer):LongString;
var Buffer: array[0..1023] of Char;
begin
 SetString(Result,Buffer,ExceptionErrorMessage(ExceptObject,ExceptAddr,Buffer,SizeOf(Buffer)));
 Result:=ExceptionInfoFilter(Result);
end;

function IsHarmlessException(E:Exception; const HarmClass:LongString=''):Boolean;
begin
 Result:=false;
 if (E=nil) then Exit;
 Result:=(E is ENiceException);
 if Result or (HarmClass='') then Exit;
 if SameText(HarmClass,ENiceException.ClassName) then Result:=true else
 if SameText(HarmClass,ESoftException.ClassName) then Result:=true else
 if SameText(HarmClass,EEchoException.ClassName) then Result:=true else
 if SameText(HarmClass,EHideException.ClassName) then Result:=true;
end;

function IsENiceException(E:Exception; const HarmClass:String=''):Boolean;
begin
 Result:=false;
 if (E=nil) then Exit;
 Result:=(E is ENiceException);
 if Result or (HarmClass='') then Exit;
 if SameText(HarmClass,ENiceException.ClassName) then Result:=true;
end;

function IsESoftException(E:Exception; const HarmClass:String=''):Boolean;
begin
 Result:=false;
 if (E=nil) then Exit;
 Result:=(E is ESoftException);
 if Result or (HarmClass='') then Exit;
 if SameText(HarmClass,ESoftException.ClassName) then Result:=true;
end;

function IsEEchoException(E:Exception; const HarmClass:String=''):Boolean;
begin
 Result:=false;
 if (E=nil) then Exit;
 Result:=(E is EEchoException);
 if Result or (HarmClass='') then Exit;
 if SameText(HarmClass,EEchoException.ClassName) then Result:=true;
end;

function IsEHideException(E:Exception; const HarmClass:String=''):Boolean;
begin
 Result:=false;
 if (E=nil) then Exit;
 Result:=(E is EHideException);
 if Result or (HarmClass='') then Exit;
 if SameText(HarmClass,EHideException.ClassName) then Result:=true;
end;

 ///////////////////////////////////////////////////////////////////////////
 // FormatHarmlessBug(C,Note) includes in head of Note marker of harm class.
 // ExtractHarmClass decode message formatted with FormatHarmlessBug(C,Note)
 // and return C.ClassName then drop class name from Note to revert original
 // Parameter Note may contain "@!ENiceException: Text" to define harm class
 // For example:
 //  on E:Exception do BugReport(E,nil,'@!ESoftException: Error found.');
 ///////////////////////////////////////////////////////////////////////////
function FormatHarmlessBug(C:TClass; const Msg:LongString):LongString;
begin
 if Assigned(C) then Result:=Format('@!%s: %s',[C.ClassName,Msg]) else Result:=Msg;
end;
function ExtractHarmClass(var Note:LongString):LongString;
var p:Integer;
begin
 Result:='';                             // Check pattern '@!E.*: '
 if Length(Note)<6 then Exit;            // String is too small
 if (Note[1]<>'@') then Exit;            // Not started from @
 if (Note[2]<>'!') then Exit;            // Not started from @!
 if UpCase(Note[3])<>'E' then Exit;      // Not started from @!E
 p:=Pos(': ',Note); if (p<5) then Exit;  // Has no ': ' clause
 if (Pos(' ',Note)<p+1) then Exit;       // Has space before :
 Result:=Copy(Note,3,p-3);               // Found, copy class
 Delete(Note,1,p+1);                     // Delete from Note
end;

procedure BugReport(E:Exception; Sender:TObject=nil; Note:LongString='');
const Exe:String[31]=''; var Info,What,Where,When,Who,Why,Harm:LongString;
begin
 try
  Harm:=ExtractHarmClass(Note);
  if E is Exception then begin
   if IsEHideException(E,Harm) then begin
    // Echo(E.Message); // Don`t need echo
    Exit;
   end;
   if IsEEchoException(E,Harm) then begin
    Echo(E.Message);
    Exit;
   end;
   When:=FormatDateTime('yyyy.mm.dd-hh:nn:ss',Now);
   What:='Exception '+DoubleAngleQuotedStr(E.ClassName);
   if (Note<>'') then Note:=' note '+DoubleAngleQuotedStr(Note);
   if Sender is TObject then Who:=Sender.ClassName else Who:='Unknown';
   if Sender is TComponent then Who:=Who+'.'+(Sender as TComponent).Name;
   if (Who<>'') then Who:=' from '+DoubleAngleQuotedStr(Who);
   if IsESoftException(E,Harm) then begin
    Why:=' hint '+DoubleAngleQuotedStr(E.Message);
    Echo(When+' => '+What+Why+Who+Note);
    Exit;
   end;
   Info:=GetExceptionInfo(ExceptObject,ExceptAddr);
   if Exe='' then Exe:=SysUtils.ExtractFileName(ParamStr(0));
   Where:=' in '+Exe+' PID '+IntToStr(Int64(GetCurrentProcessId));
   Why:=' hint '+DoubleAngleQuotedStr(ExceptionInfoFilter(E.Message));
   Echo(When+' => '+What+Where+CRLF
       +When+' => '+What+Who+Note+CRLF
       +When+' => '+What+Why+CRLF
       +When+' => '+Info);
   if not IsHarmlessException(E,Harm) then
   if Assigned(SystemSendToMainConsoleFunction) then
   SendToMainConsole('@Silent @OnException '+What+Where+CRLF
                    +'@Silent @OnException --info '+What+Who+Note+CRLF
                    +'@Silent @OnException --info '+What+Why+CRLF
                    +'@Silent @OnException --info '+Info+CRLF);
  end else begin
   if Assigned(Sender) then if (Note<>'') then Echo(Note);
  end;
 except
  on Ex:Exception do Echo(Ex.Message);
 end;
end;

var
 SafeFileWriteStrLatch : TRTLCriticalSection;

procedure SafeFileWriteStr(const FileName:ShortString; const Msg:LongString;
                           const LineBreak:LongString=CRLF);
var
 F : Text;
 I : Integer;
begin
 if (Length(FileName)>0) and (Length(Msg)+Length(LineBreak)>0) then
 try
  EnterCriticalSection(SafeFileWriteStrLatch);
  try
   I:=System.IOResult;
   System.Assign(F,FileName);
   if SysUtils.FileExists(FileName) then System.Append(F) else System.Rewrite(F);
   try
    System.Write(F,Msg+LineBreak);
   finally
    System.Close(F);
    System.SetInOutRes(I);
   end;
  finally
   LeaveCriticalSection(SafeFileWriteStrLatch);
  end;
 except
  on E:Exception do BugReport(E);
 end;
end;

 {
 ***************************
 Locked Integer manipulation
 ***************************
 }
function LockedAdd(var Target: Integer; Value: Integer): Integer; assembler;
asm
 MOV     ECX, EAX
 MOV     EAX, EDX
 LOCK XADD [ECX], EAX
 ADD     EAX, EDX
end;

function LockedCompareExchange(var Target: Integer; Exch, Comp: Integer): Integer; assembler;
asm
 XCHG    EAX, ECX
 LOCK CMPXCHG [ECX], EDX
end;

function LockedCompareExchange(var Target: Pointer; Exch, Comp: Pointer): Pointer; assembler;
asm
 XCHG    EAX, ECX
 LOCK CMPXCHG [ECX], EDX
end;

function LockedDec(var Target: Integer): Integer; assembler;
asm
 MOV     ECX, EAX
 MOV     EAX, -1
 LOCK XADD [ECX], EAX
 DEC     EAX
end;

function LockedExchange(var Target: Integer; Value: Integer): Integer; assembler;
asm
 MOV     ECX, EAX
 MOV     EAX, EDX
 LOCK XCHG [ECX], EAX
end;

function LockedExchangeAdd(var Target: Integer; Value: Integer): Integer; assembler;
asm
 MOV     ECX, EAX
 MOV     EAX, EDX
 LOCK XADD [ECX], EAX
end;

function LockedExchangeDec(var Target: Integer): Integer; assembler;
asm
 MOV     ECX, EAX
 MOV     EAX, -1
 LOCK XADD [ECX], EAX
end;

function LockedExchangeInc(var Target: Integer): Integer; assembler;
asm
 MOV     ECX, EAX
 MOV     EAX, 1
 LOCK XADD [ECX], EAX
end;

function LockedExchangeSub(var Target: Integer; Value: Integer): Integer; assembler;
asm
 MOV     ECX, EAX
 NEG     EDX
 MOV     EAX, EDX
 LOCK XADD [ECX], EAX
end;

function LockedInc(var Target: Integer): Integer; assembler;
asm
 MOV     ECX, EAX
 MOV     EAX, 1
 LOCK XADD [ECX], EAX
 INC     EAX
end;

function LockedSub(var Target: Integer; Value: Integer): Integer; assembler;
asm
 MOV     ECX, EAX
 NEG     EDX
 MOV     EAX, EDX
 LOCK XADD [ECX], EAX
 ADD     EAX, EDX
end;

initialization

 HeapAllocFlags := GMEM_MOVEABLE + GMEM_ZEROINIT;

 InitializeCriticalSection(SafeFileWriteStrLatch);

 InitBornKillLog;

 TheObjectRegistry:=TObjectRegistry.Create;
 TheObjectRegistry.Master:=TheObjectRegistry;

finalization

 ResourceLeakageLog(Format('%-60s = %d',['Balance of TLatch.Lock/Unlock',LockUnlockBalance]));
 ResourceLeakageLog(Format('%-60s = %d',['ObjectRegistry.Errors',ErrObjectRegistry]));
 ResourceLeakageLog(Format('%-60s = %d',['ObjectRegistry.Count',TheObjectRegistry.Count]));
 ResourceLeakageLog(Format('%-60s = %d',['ObjectRegistry.Space',TheObjectRegistry.Space]));
 ResourceLeakageLog(Format('%-60s = %d',['ObjectRegistry.Capacity',TheObjectRegistry.Capacity]));
 if (TheObjectRegistry.Count>0) then
 ResourceLeakageLog(Format('%-60s = %s',['ObjectRegistry.ClassNameList',TheObjectRegistry.ClassNameList]));
 TheObjectRegistry.Free;

 DoneBornKillLog;

 DeleteCriticalSection(SafeFileWriteStrLatch);

end.
