////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2023 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// This unit is for Memory allocation and addressing routines.                //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 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                    //
// 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   //
// 20230501 - Modified for FPC (A.K.)                                         //
// 20230506 - PointerToPtrInt/PtrIntToPointer (A.K.)                          //
// 20230906 - ReadTextLinesFromFile                                           //
////////////////////////////////////////////////////////////////////////////////

unit _crw_alloc; //  Memory allocation, object registry, interlocked operations.

{$IFDEF FPC}{$mode Delphi}{$ENDIF}{$H+}

{$I _crw_sysdef}

interface

uses
 _crw_sharemem, // NB: THIS UNIT MUST BE FIRST !!!
 {$IFDEF UNIX} cthreads, dl, {$ENDIF}
 {$IFDEF WINDOWS} windows, {$ENDIF}
 {$IFDEF UNIX} unix, {$ENDIF}
 {$IFDEF UNIX} baseunix, {$ENDIF}
 sysutils, classes, contnrs, math, types;

///////////////////////////////////
// System identification functions.
///////////////////////////////////
function IsUnix    : Boolean; inline;
function IsLinux   : Boolean; inline;
function IsWindows : Boolean; inline;
function IsWin32   : Boolean; inline;
function IsWin64   : Boolean; inline;
function IsCpu16   : Boolean; inline;
function IsCpu32   : Boolean; inline;
function IsCpu64   : Boolean; inline;
function IsCpuBE   : Boolean; inline;
function IsCpuLE   : Boolean; inline;
function IsSysUtf8 : Boolean; inline;

function IsFileNameCaseSensitive : Boolean;

const
 TheCrwVendorName:String='DaqGroup';

////////////////////////////////////
// System general purpose constants.
////////////////////////////////////

const
 CRLF = #13#10;      // Text line delimiter for DOS, Windows.
 EOL  = LineEnding;  // End Of Line delimeter for current OS.

const                // Posix PIPE_BUF = atomic pipe IO buffer.
 OS_PIPE_BUF = 4096; // Number of bytes in atomic write to a pipe (Linux).

const                // Succeed error codes.
 NO_ERROR      = 0;  // No error found.
 ERROR_SUCCESS = 0;  // Success status.

const                             // From Windows API: useful constants.
 STATUS_PENDING = $103; {259}     // Operation requested pending completion.
 STILL_ACTIVE   = STATUS_PENDING; // The thread or process is still active.

const // Standard formats for FormatDateTime function
 StdTimeOnlyFormat   = 'hh:nn:ss';                // Standard     Time Format
 StdDateOnlyFormat   = 'yyyy.mm.dd';              // Standard Date     Format
 StdTimeOnlyFormatMs = 'hh:nn:ss.zzz';            // Standard Time Format +ms
 StdDateTimeFormat   = 'yyyy.mm.dd-hh:nn:ss';     // Standard DateTime Format
 StdDateTimeFormatMs = 'yyyy.mm.dd-hh:nn:ss.zzz'; // Date Time Format with ms

const // Severity levels for error handlers and messages
 SEVERITY_INFO       = 0;            // No error(s), just for information
 SEVERITY_WARNING    = 1;            // Warning, maybe it`s not error yet
 SEVERITY_ERROR      = 2;            // Error found (recoverable)
 SEVERITY_FATAL      = 3;            // Fatal error (unrecoverable)
 SEVERITY_NAMES      = 'INFO'+EOL+'WARNING'+EOL+'ERROR'+EOL+'FATAL'+EOL;

const // Unix/Posix file access constants   // Possible values  for mode
 S_IRUSR = &400; // %0100000000;            // Read permission  for owner
 S_IWUSR = &200; // %0010000000;            // Write permission for owner
 S_IXUSR = &100; // %0001000000;            // Exec  permission for owner
 S_IRGRP = &040; // %0000100000;            // Read permission  for group
 S_IWGRP = &020; // %0000010000;            // Write permission for group
 S_IXGRP = &010; // %0000001000;            // Exec permission  for group
 S_IROTH = &004; // %0000000100;            // Read permission  for other
 S_IWOTH = &002; // %0000000010;            // Write permission for other
 S_IXOTH = &001; // %0000000001;            // Exec permission  for other
 S_IRWXU = S_IRUSR or S_IWUSR or S_IXUSR;   // Read Write Exec  for owner
 S_IRWXG = S_IRGRP or S_IWGRP or S_IXGRP;   // Read Write Exec  for group
 S_IRWXO = S_IROTH or S_IWOTH or S_IXOTH;   // Read Write Exec  for other
const                                       // Over Posix
 S_IRWXUG  = S_IRWXU or S_IRWXG;            // Read Write Exec  for USR/GRP
 S_IRWXUGO = S_IRWXU or S_IRWXG or S_IRWXO; // Read Write Exec  for all

type
 TPid = SizeInt; // Base type for ProcessID

function IsMainThread:Boolean;         inline;

function GetCurrentProcessId:TPid;     inline;

function GetAllocMemCount:SizeInt;     inline;
function GetAllocMemSize:SizeInt;      inline;

 {
 Simulate Delphi`s stuff.
 }
procedure SetInOutRes(Res:Integer); inline;

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

function GetAllocMemBalance:SizeInt;
function GetAllocateBalance:SizeInt;
function GetBornKillBalance:SizeInt;
function GetAllocErrorCount:SizeInt;
function GetBornKillFile:ShortString;

function BornKillLog(const s:ShortString):Boolean;
function ResourceLeakageLog(const s:ShortString):Boolean;
function OpenResourceLeakageLogFile(const FileName:ShortString):Boolean;

 {
 *********************************************
 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.
 PointerToPtrInt(P)          Return (convert) pointer P as PtrInt  value
 PointerToPtrUInt(P)         Return (convert) pointer P as PtrUInt value
 PtrIntToPointer(I)          Return (convert) PtrInt  value I as pointer
 PtrUIntToPointer(I)         Return (convert) PtrUInt value I as pointer
 SubtractPointersAsPtrInt(P1,P2)  Subtract Pointers (P1-P2) as PtrInt  value
 SubtractPointersAsPtrUInt(P1,P2) Subtract Pointers (P1-P2) as PtrUInt value
 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:SizeInt):Pointer; inline;
function  DecPtr(Base:Pointer; ByteOffset:SizeInt):Pointer; inline;
function  PointerToPtrInt(P:Pointer):PtrInt;                inline;
function  PointerToPtrUInt(P:Pointer):PtrUInt;              inline;
function  PtrIntToPointer(I:PtrInt):Pointer;                inline;
function  PtrUIntToPointer(I:PtrUInt):Pointer;              inline;
function  SubtractPointersAsPtrInt(P1,P2:Pointer):PtrInt;
function  SubtractPointersAsPtrUInt(P1,P2:Pointer):PtrUInt;
procedure SafeMove(const Source; out Dest; Count: SizeInt);
procedure SafeFillChar(out X; Count:SizeInt; Value:Byte); overload;
procedure SafeFillChar(out X; Count:SizeInt; Value:Char); overload;
procedure ZeroMemory(Destination:Pointer; Count:SizeInt);
function  AdjustBufferSize(Size:SizeInt; Step:SizeInt):SizeInt;

 {
 *************************************************************************
 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:SizeInt):Pointer;
function  Deallocate(var P:Pointer):Boolean;
function  AllocSize(P:Pointer):SizeInt;
function  Reallocate(var P:Pointer; N:SizeInt):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;

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

const
 KiloByte        = 1024;
 MegaByte        = KiloByte*KiloByte;
 GigaByte        = MegaByte*KiloByte;

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

type                                     // windows compatible types
 LPDWORD         = system.pdword;        //
 LANGID          = system.word;          //
 LCID            = system.dword;         //

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);
 MaxNumSizeInt   = MaxNumByte div sizeof(SizeInt);
 MaxNumSizeUInt  = MaxNumByte div sizeof(SizeUInt);
 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;
 TSizeIntArray   = packed array[0..MaxNumSizeInt-1]  of SizeInt;
 TSizeUIntArray  = packed array[0..MaxNumSizeUInt-1] of SizeUInt;
 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;
 PSizeIntArray   = ^TSizeIntArray;
 PSizeUIntArray  = ^TSizeUIntArray;
 PLongIntArray   = ^TLongIntArray;
 PCardinalArray  = ^TCardinalArray;
 PIntegerArray   = ^TIntegerArray;
 PInt64Array     = ^TInt64Array;
 PSingleArray    = ^TSingleArray;
 PDoubleArray    = ^TDoubleArray;
 PCompArray      = ^TCompArray;
 PExtendedArray  = ^TExtendedArray;
 PPointerArray   = ^TPointerArray;

 {
 *************************************************
 Long strings are often uses as memory buffers.
 StringBuffer(Leng,Filler) allocates string buffer
 of length (Leng) and fill him with char (Filler).
 StringBuffer(Buff,Leng) creates string from Buff.
 *************************************************
 }
function StringBuffer(Leng:SizeInt; Filler:Char=#0):LongString; overload;
function StringBuffer(Buff:Pointer; Leng:SizeInt):LongString; overload;

 {
 *******************************************************************************
 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);
 PMasterObject = ^TMasterObject;
 TMasterObject = class(TObject)
 private
  myRef      : Integer;
  myMaster   : PMasterObject;
  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;
  function    GetMaster:PMasterObject;
  procedure   SetMaster(aMaster:PMasterObject);
  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          : PMasterObject  read  GetMaster write SetMaster;
  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(aRef:Integer):TObject;
 public
  constructor Create;
  destructor  Destroy; override;
  function    InitRef(Obj:TObject):Integer;
  function    FreeRef(aRef: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=EOL);

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;

type
 TSendToMainConsoleFunction = function(const Msg:LongString):Integer;

const
 SystemSendToMainConsoleFunction : TSendToMainConsoleFunction = 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.
 *******************************************************************************
 }
function SafeFileWriteStr(const FileName:ShortString; const Msg:LongString;
                          const LineBreak:LongString=EOL):Boolean;

 {
 Read text lines from file as long string.
 }
function ReadTextLinesFromFile(FileName:LongString):LongString;

 {
 *******************************************************************************
 Locked Integer manipulation in a thread safe manner.
 That is simplest and fastest way for thread/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         |
 | LockedGet             | Target                | Target         |
 | LockedSet             | Value                 | void           |
 |-----------------------|-----------------------|----------------|
 *******************************************************************************
 }
function LockedAdd(var Target:LongInt; Value:LongInt):LongInt; overload;
function LockedAdd(var Target:Cardinal; Value:Cardinal):Cardinal; overload;
{$IFDEF CPU64}
function LockedAdd(var Target:SizeInt; Value:SizeInt):SizeInt; overload;
function LockedAdd(var Target:SizeUInt; Value:SizeUInt):SizeUInt; overload;
{$ENDIF}
function LockedCompareExchange(var Target:LongInt; Exch, Comp: LongInt):LongInt; overload;
function LockedCompareExchange(var Target:Cardinal; Exch, Comp: Cardinal):Cardinal; overload;
{$IFDEF CPU64}
function LockedCompareExchange(var Target:SizeInt; Exch, Comp: SizeInt):SizeInt; overload;
function LockedCompareExchange(var Target:SizeUInt; Exch, Comp: SizeUInt):SizeUInt; overload;
{$ENDIF}
function LockedDec(var Target:LongInt):LongInt; overload;
function LockedDec(var Target:Cardinal):Cardinal; overload;
{$IFDEF CPU64}
function LockedDec(var Target:SizeInt):SizeInt; overload;
function LockedDec(var Target:SizeUInt):SizeUInt; overload;
{$ENDIF}
function LockedExchange(var Target:LongInt; Value:LongInt):LongInt; overload;
function LockedExchange(var Target:Cardinal; Value:Cardinal):Cardinal; overload;
{$IFDEF CPU64}
function LockedExchange(var Target:SizeInt; Value:SizeInt):SizeInt; overload;
function LockedExchange(var Target:SizeUInt; Value:SizeUInt):SizeUInt; overload;
{$ENDIF}
function LockedExchangeAdd(var Target:LongInt; Value:LongInt):LongInt; overload;
function LockedExchangeAdd(var Target:Cardinal; Value:Cardinal):Cardinal; overload;
{$IFDEF CPU64}
function LockedExchangeAdd(var Target:SizeInt; Value:SizeInt):SizeInt; overload;
function LockedExchangeAdd(var Target:SizeUInt; Value:SizeUInt):SizeUInt; overload;
{$ENDIF}
function LockedExchangeDec(var Target:LongInt):LongInt; overload;
function LockedExchangeDec(var Target:Cardinal):Cardinal; overload;
{$IFDEF CPU64}
function LockedExchangeDec(var Target:SizeInt):SizeInt; overload;
function LockedExchangeDec(var Target:SizeUInt):SizeUInt; overload;
{$ENDIF}
function LockedExchangeInc(var Target:LongInt):LongInt; overload;
function LockedExchangeInc(var Target:Cardinal):Cardinal; overload;
{$IFDEF CPU64}
function LockedExchangeInc(var Target:SizeInt):SizeInt; overload;
function LockedExchangeInc(var Target:SizeUInt):SizeUInt; overload;
{$ENDIF}
function LockedExchangeSub(var Target:LongInt; Value:LongInt):LongInt; overload;
function LockedExchangeSub(var Target:Cardinal; Value:Cardinal):Cardinal; overload;
{$IFDEF CPU64}
function LockedExchangeSub(var Target:SizeInt; Value:SizeInt):SizeInt; overload;
function LockedExchangeSub(var Target:SizeUInt; Value:SizeUInt):SizeUInt; overload;
{$ENDIF}
function LockedInc(var Target:LongInt):LongInt; overload;
function LockedInc(var Target:Cardinal):Cardinal; overload;
{$IFDEF CPU64}
function LockedInc(var Target:SizeInt):SizeInt; overload;
function LockedInc(var Target:SizeUInt):SizeUInt; overload;
{$ENDIF}
function LockedSub(var Target:LongInt; Value:LongInt):LongInt; overload;
function LockedSub(var Target:Cardinal; Value:Cardinal):Cardinal; overload;
{$IFDEF CPU64}
function LockedSub(var Target:SizeInt; Value:SizeInt):SizeInt; overload;
function LockedSub(var Target:SizeUInt; Value:SizeUInt):SizeUInt; overload;
{$ENDIF}
function LockedGet(var Target:LongInt):LongInt; overload;
function LockedGet(var Target:Cardinal):Cardinal; overload;
{$IFDEF CPU64}
function LockedGet(var Target:SizeUInt):SizeUInt; overload;
function LockedGet(var Target:SizeInt):SizeInt; overload;
{$ENDIF}
procedure LockedSet(var Target:LongInt; Value:LongInt); overload;
procedure LockedSet(var Target:Cardinal; Value:Cardinal); overload;
{$IFDEF CPU64}
procedure LockedSet(var Target:SizeInt; Value:SizeInt); overload;
procedure LockedSet(var Target:SizeUInt; Value:SizeUInt); overload;
{$ENDIF}

var SystemThreadManager:TThreadManager; // Initial ThreadManager

implementation

function IsUnix    : Boolean; begin Result := {$IFDEF UNIX}          true {$ELSE} false {$ENDIF}; end;
function IsLinux   : Boolean; begin Result := {$IFDEF LINUX}         true {$ELSE} false {$ENDIF}; end;
function IsWindows : Boolean; begin Result := {$IFDEF WINDOWS}       true {$ELSE} false {$ENDIF}; end;
function IsWin32   : Boolean; begin Result := {$IFDEF WIN32}         true {$ELSE} false {$ENDIF}; end;
function IsWin64   : Boolean; begin Result := {$IFDEF WIN64}         true {$ELSE} false {$ENDIF}; end;
function IsCpu16   : Boolean; begin Result := {$IFDEF CPU16}         true {$ELSE} false {$ENDIF}; end;
function IsCpu32   : Boolean; begin Result := {$IFDEF CPU32}         true {$ELSE} false {$ENDIF}; end;
function IsCpu64   : Boolean; begin Result := {$IFDEF CPU64}         true {$ELSE} false {$ENDIF}; end;
function IsCpuBE   : Boolean; begin Result := {$IFDEF ENDIAN_BIG}    true {$ELSE} false {$ENDIF}; end;
function IsCpuLE   : Boolean; begin Result := {$IFDEF ENDIAN_LITTLE} true {$ELSE} false {$ENDIF}; end;
function IsSysUtf8 : Boolean; begin Result:=(DefaultSystemCodePage=CP_UTF8); end;

function IsFileNameCaseSensitive:Boolean;
begin
 Result:=System.FileNameCaseSensitive;
end;

function IsMainThread:Boolean;
begin
 Result:=(GetCurrentThreadId=MainThreadId);
end;

function GetCurrentProcessId:TPid;
begin
 Result:=GetProcessId;
end;

function GetAllocMemCount:SizeInt;
begin
 Result:=GetHeapStatus.TotalAllocated;
end;

function GetAllocMemSize:SizeInt;
begin
 Result:=GetHeapStatus.TotalAllocated;
end;

procedure SetInOutRes(Res:Integer);
begin
 System.InOutRes:=Res;
end;

function StringBuffer(Leng:SizeInt; Filler:Char=#0):LongString;
begin
 Result:='';
 if (Leng<=0) then Exit;
 SetLength(Result,Leng);
 FillChar(Pointer(Result)^,Length(Result),Filler);
end;

function StringBuffer(Buff:Pointer; Leng:SizeInt):LongString;
begin
 Result:='';
 if (Leng>0) then
 if Assigned(Buff)
 then SetString(Result,Buff,Leng)
 else Result:=StringBuffer(Leng);
end;

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

function GetAllocMemBalance:SizeInt;  begin Result:=LockedGet(AllocMemBalance); end;
function GetAllocateBalance:SizeInt;  begin Result:=LockedGet(AllocateBalance); end;
function GetBornKillBalance:SizeInt;  begin Result:=LockedGet(BornKillBalance); end;
function GetAllocErrorCount:SizeInt;  begin Result:=LockedGet(AllocErrorCount); end;
function GetBornKillFile:ShortString; begin Result:=TheBornKillFile; end;

function BornKillLog(const s:ShortString):Boolean;
begin
 if UsesBornKillLog
 then Result:=SafeFileWriteStr(TheBornKillFile,s)
 else Result:=false;
end;

function  ResourceLeakageLog(const s:ShortString):Boolean;
begin
 if (Length(ResourceLeakageLogFile)>0)
 then Result:=SafeFileWriteStr(ResourceLeakageLogFile,s)
 else Result:=false;
end;

function OpenResourceLeakageLogFile(const FileName:ShortString):Boolean;
var date,exec,msg:LongString;
begin
 Result:=false;
 ResourceLeakageLogFile:=Trim(FileName);
 if (ResourceLeakageLogFile='') then Exit;
 exec:=ExtractFileName(ParamStr(0));
 date:=FormatDateTime(StdDateTimeFormat,Now);
 if not FileExists(ResourceLeakageLogFile)
 then msg:='Resource Leakage Log file'+EOL
          +'*************************'+EOL+EOL
 else msg:=EOL;
 msg:=msg+Format('Enter %s at %s',[exec,date]);
 Result:=ResourceLeakageLog(msg);
end;

procedure InitBornKillLog;
var i:Integer; Dir:String;
begin
 AllocMemBalance:=GetAllocMemSize;
 Dir:=ExtractFilePath(ParamStr(0));
 TheBornKillFile:=IncludeTrailingPathDelimiter(Dir)+BornKillLogFileName;
 if FileExists(TheBornKillFile) then DeleteFile(TheBornKillFile);
 UsesBornKillLog:=false;
 for i:=1 to ParamCount do
 if SameText(ParamStr(i),UsesBornKillLogParamStr) then begin
  UsesBornKillLog:=true;
  Break;
 end;
end;

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

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

function IncPtr(Base:Pointer; ByteOffset:SizeInt):Pointer;
begin
 Result:=(PChar(Base)+ByteOffset);
end;

function DecPtr(Base:Pointer; ByteOffset:SizeInt):Pointer;
begin
 Result:=(PChar(Base)-ByteOffset);
end;

function PointerToPtrInt(P:Pointer):PtrInt;
var I : PtrInt absolute P;
begin
 Result:=I;
end;

function PointerToPtrUInt(P:Pointer):PtrUInt;
var I : PtrUInt absolute P;
begin
 Result:=I;
end;

function PtrIntToPointer(I:PtrInt):Pointer;
var P : Pointer absolute I;
begin
 Result:=P;
end;

function PtrUIntToPointer(I:PtrUInt):Pointer;
var P : Pointer absolute I;
begin
 Result:=P;
end;

function SubtractPointersAsPtrInt(P1,P2:Pointer):PtrInt;
var I1 : PtrInt absolute P1;
var I2 : PtrInt absolute P2;
begin
 Result:=I1-I2;
end;

function SubtractPointersAsPtrUInt(P1,P2:Pointer):PtrUInt;
var I1 : PtrUInt absolute P1;
var I2 : PtrUInt absolute P2;
begin
 Result:=I1-I2;
end;

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

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

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

procedure ZeroMemory(Destination:Pointer; Count:SizeInt);
begin
 if (Count>0) and (Destination<>nil) then FillChar(Destination^,Count,0);
end;

function  AdjustBufferSize(Size:SizeInt; Step:SizeInt):SizeInt;
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   : SizeInt;
  NotSize   : SizeInt;
  TheData   : packed record end;
 end;

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

function myMemFree(P:Pointer; Size:SizeInt):Boolean;
begin
 Result:=false;
 if Assigned(P) then
 try
  FreeMem(P,Size);
  LockedSub(AllocateBalance,Size);
  Result:=true;
 except
  on E:Exception do begin
   LockedInc(AllocErrorCount);
   BugReport(E,nil,'myMemFree');
   Result:=false
  end;
 end;
end;

function Allocate(N:SizeInt):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,nil,'Allocate');
   Result:=nil;
  end;
 end;
end;

function Deallocate(var P:Pointer):Boolean;
var PP:Pointer;
begin
 Result:=false;
 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 Result:=myMemFree(PP,TheSize+SizeOf(TInfoBlock))
   else LockedInc(AllocErrorCount);
  end else LockedInc(AllocErrorCount);
 except
  on E:Exception do begin
   LockedInc(AllocErrorCount);
   BugReport(E,nil,'Deallocate');
   Result:=false;
  end;
 end;
end;

function AllocSize(P:Pointer):SizeInt;
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,nil,'AllocSize');
   Result:=0;
  end;
 end;
end;

function Reallocate(var P:Pointer; N:SizeInt):Boolean;
var OldData,NewData:Pointer; OldSize,NewSize:SizeInt;
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,nil,'Reallocate');
   Result:=false;
  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,nil,'Kill');
 end;
end;

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

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

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

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

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

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

procedure Kill(var TheObject:TMemoryStream); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 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, IntPtr(Self), GetCurrentThreadID, BornKillBalance]));
 LockedInc(BornKillBalance);
 if not (Self is TObjectRegistry) then myRef:=ObjectRegistry.InitRef(Self);
end;

procedure TMasterObject.BeforeDestruction;
begin
 if not (Self is TObjectRegistry) then ObjectRegistry.FreeRef(myRef);
 LockedDec(BornKillBalance);
 if UsesBornKillLog
 then BornKillLog(Format('KILL %-25s %8.8x %8.8x %d',
                  [ClassName, PtrInt(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;

function TMasterObject.GetMaster:PMasterObject;
begin
 if Assigned(Self) then Result:=myMaster else Result:=nil;
end;

procedure TMasterObject.SetMaster(aMaster:PMasterObject);
begin
 if Assigned(Self) then
 try
  if (aMaster<>nil) and (aMaster^=Self) then myMaster:=aMaster else myMaster:=nil;
 except
  on E:Exception do BugReport(E,Self,'SetMaster');
 end;
end;

procedure TMasterObject.ClearMaster;
begin
 if Assigned(Self) then
 try
  if Assigned(myMaster) then if myMaster^=Self then myMaster^:=nil;
  myMaster:=nil;
 except
  on E:Exception do BugReport(E,Self,'ClearMaster');
 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 : SizeInt = 0;

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

destructor TLatch.Destroy;
begin
 DoneCriticalSection(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,nil,'NewLatch');
 end;
end;

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

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

function ObjectRegistry:TObjectRegistry;
begin
 if (TheObjectRegistry=nil) then begin
  TheObjectRegistry:=TObjectRegistry.Create;
  TheObjectRegistry.Master:=@TheObjectRegistry;
 end;
 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(aRef:Integer):TObject;
begin
 Result:=nil;
 if Assigned(Self) then begin
  Lock;
  Dec(aRef,ObjectRegistryOffset);
  if (aRef>=0) and (aRef<myCapac) then Result:=myTable[aRef];
  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 (i<0) or (i>=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,'InitRef');
 end;
end;

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

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

function TObjectRegistry.ClassNameList:String;
var Lines:TStringList;
begin
 Result:='';
 if Count=0 then Exit;
 try
  Lines:=TStringList.Create;
  try
   ForEach(ClassNameListCallback,Lines);
   Result:=StringReplace(SysUtils.Trim(Lines.Text),EOL,',',[rfReplaceAll]);
  finally
   Lines.Free;
  end;
 except
  on E:Exception do BugReport(E,Self,'ClassNameList');
 end;
end;

procedure Echo(const Msg:LongString; const LineBreak:LongString=EOL);
begin
 if Assigned(SystemEchoProcedure) then
 try
  SystemEchoProcedure(Msg+LineBreak);
 except
  on E:Exception do BugReport(E,nil,'Echo');
 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,nil,'SendToMainConsole');
 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:=AdjustLineBreaks(Info);
 Result:=StringReplace(Result,EOL,' ',[rfReplaceAll]);
 Result:=Trim(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: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;
end;

function IsESoftException(E:Exception; const HarmClass:LongString=''):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:LongString=''):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:LongString=''):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+EOL
       +When+' => '+What+Who+Note+EOL
       +When+' => '+What+Why+EOL
       +When+' => '+Info);
   if not IsHarmlessException(E,Harm) then
   if Assigned(SystemSendToMainConsoleFunction) then
   SendToMainConsole('@Silent @OnException '+What+Where+EOL
                    +'@Silent @OnException --info '+What+Who+Note+EOL
                    +'@Silent @OnException --info '+What+Why+EOL
                    +'@Silent @OnException --info '+Info+EOL);
  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;

function SafeFileWriteStr(const FileName:ShortString; const Msg:LongString;
                           const LineBreak:LongString=EOL):Boolean;
var F:Text; I:Integer;
begin
 Result:=false;
 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);
    if (System.IOResult=0) then Result:=true;
   finally
    System.Close(F);
    if (I<>0) then {System.SetInOutRes(I)};
   end;
  finally
   LeaveCriticalSection(SafeFileWriteStrLatch);
  end;
 except
  on E:Exception do BugReport(E,nil,'SafeFileWriteStr');
 end;
end;

function ReadTextLinesFromFile(FileName:LongString):LongString;
var Lines:TStringList;
begin
 Result:='';
 {$IFDEF UNIX}
 if (FpAccess(FileName,R_OK)<>NO_ERROR) then Exit;
 {$ENDIF}
 if FileExists(FileName) then
 try
  Lines:=TStringList.Create;
  try
   Lines.LoadFromFile(FileName);
   Result:=Lines.Text;
  finally
   Lines.Free;
  end;
 except
  on E:Exception do BugReport(E,nil,'ReadTextLinesFromFile');
 end;
end;

 {
 ***************************
 Locked Integer manipulation
 ***************************
 }
function LockedAdd(var Target:LongInt; Value:LongInt):LongInt;
begin
 Result:=System.InterlockedExchangeAdd(Target,Value)+Value;
end;
function LockedAdd(var Target:Cardinal; Value:Cardinal):Cardinal;
begin
 Result:=System.InterlockedExchangeAdd(Target,Value)+Value;
end;
{$IFDEF CPU64}
function LockedAdd(var Target:SizeUInt; Value:SizeUInt):SizeUInt;
begin
 Result:=System.InterlockedExchangeAdd64(Target,Value)+Value;
end;
function LockedAdd(var Target:SizeInt; Value:SizeInt):SizeInt;
begin
 Result:=System.InterlockedExchangeAdd64(Target,Value)+Value;
end;
{$ENDIF}

function LockedCompareExchange(var Target:LongInt; Exch, Comp: LongInt):LongInt;
begin
 Result:=System.InterlockedCompareExchange(Target,Exch,Comp);
end;
function LockedCompareExchange(var Target:Cardinal; Exch, Comp: Cardinal):Cardinal;
begin
 Result:=System.InterlockedCompareExchange(Target,Exch,Comp);
end;
{$IFDEF CPU64}
function LockedCompareExchange(var Target:SizeInt; Exch, Comp: SizeInt):SizeInt;
begin
 Result:=System.InterlockedCompareExchange64(Target,Exch,Comp);
end;
function LockedCompareExchange(var Target:SizeUInt; Exch, Comp: SizeUInt):SizeUInt;
begin
 Result:=System.InterlockedCompareExchange64(Target,Exch,Comp);
end;
{$ENDIF}

function LockedDec(var Target:LongInt):LongInt;
begin
 Result:=System.InterlockedDecrement(Target);
end;
function LockedDec(var Target:Cardinal):Cardinal;
begin
 Result:=System.InterlockedDecrement(Target);
end;
{$IFDEF CPU64}
function LockedDec(var Target:SizeInt):SizeInt;
begin
 Result:=System.InterlockedDecrement64(Target);
end;
function LockedDec(var Target:SizeUInt):SizeUInt;
begin
 Result:=System.InterlockedDecrement64(Target);
end;
{$ENDIF}

function LockedExchange(var Target:LongInt; Value:LongInt):LongInt;
begin
 Result:=System.InterlockedExchange(Target,Value);
end;
function LockedExchange(var Target:Cardinal; Value:Cardinal):Cardinal;
begin
 Result:=System.InterlockedExchange(Target,Value);
end;
{$IFDEF CPU64}
function LockedExchange(var Target:SizeInt; Value:SizeInt):SizeInt;
begin
 Result:=System.InterlockedExchange64(Target,Value);
end;
function LockedExchange(var Target:SizeUInt; Value:SizeUInt):SizeUInt;
begin
 Result:=System.InterlockedExchange64(Target,Value);
end;
{$ENDIF}

function LockedExchangeAdd(var Target:LongInt; Value:LongInt):LongInt;
begin
 Result:=System.InterlockedExchangeAdd(Target,Value);
end;
function LockedExchangeAdd(var Target:Cardinal; Value:Cardinal):Cardinal;
begin
 Result:=System.InterlockedExchangeAdd(Target,Value);
end;
{$IFDEF CPU64}
function LockedExchangeAdd(var Target:SizeInt; Value:SizeInt):SizeInt;
begin
 Result:=System.InterlockedExchangeAdd64(Target,Value);
end;
function LockedExchangeAdd(var Target:SizeUInt; Value:SizeUInt):SizeUInt;
begin
 Result:=System.InterlockedExchangeAdd64(Target,Value);
end;
{$ENDIF}

function LockedExchangeDec(var Target:LongInt):LongInt;
begin
 Result:=System.InterlockedExchangeAdd(Target,-1);
end;
function LockedExchangeDec(var Target:Cardinal):Cardinal;
begin
 Result:=System.InterlockedExchangeAdd(Target,High(Cardinal)); // Same as -1
end;
{$IFDEF CPU64}
function LockedExchangeDec(var Target:SizeInt):SizeInt;
begin
 Result:=System.InterlockedExchangeAdd64(Target,-1);
end;
function LockedExchangeDec(var Target:SizeUInt):SizeUInt;
begin
 Result:=System.InterlockedExchangeAdd64(Target,High(SizeUInt)); // Same as -1
end;
{$ENDIF}

function LockedExchangeInc(var Target:LongInt):LongInt;
begin
 Result:=System.InterlockedExchangeAdd(Target,1);
end;
function LockedExchangeInc(var Target:Cardinal):Cardinal;
begin
 Result:=System.InterlockedExchangeAdd(Target,1);
end;
{$IFDEF CPU64}
function LockedExchangeInc(var Target:SizeInt):SizeInt;
begin
 Result:=System.InterlockedExchangeAdd64(Target,1);
end;
function LockedExchangeInc(var Target:SizeUInt):SizeUInt;
begin
 Result:=System.InterlockedExchangeAdd64(Target,1);
end;
{$ENDIF}

function LockedExchangeSub(var Target:LongInt; Value:LongInt):LongInt;
begin
 Result:=System.InterlockedExchangeAdd(Target,-Value);
end;
function LockedExchangeSub(var Target:Cardinal; Value:Cardinal):Cardinal;
begin
 Result:=System.InterlockedExchangeAdd(Target,-Value);
end;
{$IFDEF CPU64}
function LockedExchangeSub(var Target:SizeInt; Value:SizeInt):SizeInt;
begin
 Result:=System.InterlockedExchangeAdd64(Target,-Value);
end;
function LockedExchangeSub(var Target:SizeUInt; Value:SizeUInt):SizeUInt;
begin
 Result:=System.InterlockedExchangeAdd64(Target,-Value);
end;
{$ENDIF}

function LockedInc(var Target:LongInt):LongInt;
begin
 Result:=System.InterlockedIncrement(Target);
end;
function LockedInc(var Target:Cardinal):Cardinal;
begin
 Result:=System.InterlockedIncrement(Target);
end;
{$IFDEF CPU64}
function LockedInc(var Target:SizeInt):SizeInt;
begin
 Result:=System.InterlockedIncrement64(Target);
end;
function LockedInc(var Target:SizeUInt):SizeUInt;
begin
 Result:=System.InterlockedIncrement64(Target);
end;
{$ENDIF}

function LockedSub(var Target:LongInt; Value:LongInt):LongInt;
begin
 Result:=System.InterlockedExchangeAdd(Target,-Value)-Value;
end;
function LockedSub(var Target:Cardinal; Value:Cardinal):Cardinal;
begin
 Result:=System.InterlockedExchangeAdd(Target,-Value)-Value;
end;
{$IFDEF CPU64}
function LockedSub(var Target:SizeInt; Value:SizeInt):SizeInt;
begin
 Result:=System.InterlockedExchangeAdd64(Target,-Value)-Value;
end;
function LockedSub(var Target:SizeUInt; Value:SizeUInt):SizeUInt;
begin
 Result:=System.InterlockedExchangeAdd64(Target,-Value)-Value;
end;
{$ENDIF}
function LockedGet(var Target:LongInt):LongInt;
begin
 Result:=System.InterlockedExchangeAdd(Target,0);
end;
function LockedGet(var Target:Cardinal):Cardinal;
begin
 Result:=System.InterlockedExchangeAdd(Target,0);
end;
{$IFDEF CPU64}
function LockedGet(var Target:SizeUInt):SizeUInt;
begin
 Result:=System.InterlockedExchangeAdd64(Target,0);
end;
function LockedGet(var Target:SizeInt):SizeInt;
begin
 Result:=System.InterlockedExchangeAdd64(Target,0);
end;
{$ENDIF}

procedure LockedSet(var Target:LongInt; Value:LongInt);
begin
 System.InterlockedExchange(Target,Value);
end;
procedure LockedSet(var Target:Cardinal; Value:Cardinal);
begin
 System.InterlockedExchange(Target,Value);
end;
{$IFDEF CPU64}
procedure LockedSet(var Target:SizeInt; Value:SizeInt);
begin
 System.InterlockedExchange64(Target,Value);
end;
procedure LockedSet(var Target:SizeUInt; Value:SizeUInt);
begin
 System.InterlockedExchange64(Target,Value);
end;
{$ENDIF}

function crwGetVendorNameEvent:String;
begin
 Result:=TheCrwVendorName;
 if IsFileNameCaseSensitive
 then Result:=LowerCase(Result);
 Result:=Trim(Result);
end;

procedure SaveSystemThreadManager;
begin
 if not GetThreadManager(SystemThreadManager)
 then SafeFillChar(SystemThreadManager,SizeOf(SystemThreadManager),0);
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_alloc;
begin
 SaveSystemThreadManager;
 OnGetVendorName:=crwGetVendorNameEvent;
 InitCriticalSection(SafeFileWriteStrLatch);
 InitBornKillLog;
 ObjectRegistry.Ok;
end;

procedure Free_crw_alloc;
begin
 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;
 DoneCriticalSection(SafeFileWriteStrLatch);
end;

initialization

 Init_crw_alloc;

finalization

 Free_crw_alloc;

end.

//////////////
// END OF FILE
//////////////

