////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 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                                           //
// 20231209 - OsName                                                          //
// 20240321 - FakeNOP, GetFpcVersion,..,GetFpcTargetPlatform                  //
// 20240704 - IsFpc                                                           //
// 20240821 - NumBitsPerByte,CpuBitness,LeastPowerOfTwo                       //
// 20240822 - PureString                                                      //
// 20241116 - TObjectRegistry.ref_min,ref_max                                 //
// 20250120 - TSysCriticalSection (data align bug in ALSE)                    //
// 20250128 - Use TAtomicCounter                                              //
// 20250130 - TSysCriticalSection moved to _crw_critsect                      //
// 20250821 - SysLogNote,SysLogNotable,SysLogErrorCounter                     //
// 20250402 - UniqName,UniqCode                                               //
// 20250403 - UniqNumberGenerator                                             //
// 20260425 - FreeAndZero                                                     //
// 20260515 - ReadTextLinesFromFileCallback                                   //
////////////////////////////////////////////////////////////////////////////////

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

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 {$IFDEF UNIX} unix, {$ENDIF}
 {$IFDEF UNIX} baseunix, {$ENDIF}
 sysutils, classes, contnrs, math, types,
 _crw_atomic, _crw_critsect;

///////////////////////////////////
// System identification functions.
///////////////////////////////////
function IsFpc     : Boolean; inline;
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;

function OsName(Mode:Integer=1):String;

function GetFpcVersion:String;        // like 3.2.0
function GetFpcTargetOS:String;       // like linux
function GetFpcTargetCPU:String;      // like x86_64
function GetFpcTargetPlatform:String; // like x86_64-linux

function  GetLastOsError:LongInt; inline;
procedure SetLastOsError(err:LongInt); inline;

const                                             // CPU/RAM bitness
 NumBitsPerByte = 8;                              // Number of Bits per Byte
 CpuBitness     = SizeOf(Pointer)*NumBitsPerByte; // System CPU/RAM Bitness

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
 StdTimeOnlyFormat2  = 'hh:mm:ss';                // Standard     Time Format
 StdTimeOnlyFormatM2 = 'hh:mm:ss.zzz';            // Standard Time Format +ms
 StdDateTimeFormat2  = 'yyyy.mm.dd-hh:mm:ss';     // Standard DateTime Format
 StdDateTimeFormatM2 = 'yyyy.mm.dd-hh:mm:ss.zzz'; // Date Time Format with ms

const // Severity levels for error handlers and messages
 SEVERITY_DEBUG      = 0;            // No error(s), just for debugging
 SEVERITY_INFO       = 1;            // No error(s), just for information
 SEVERITY_WARN       = 2;            // Warning, maybe it`s not error yet
 SEVERITY_ERROR      = 3;            // Error found (recoverable)
 SEVERITY_FATAL      = 4;            // Fatal error (unrecoverable)
 SEVERITY_OFF        = 5;            // Any kind of messages is OFF
 SEVERITY_NAMES      = 'DEBUG'+EOL+'INFO'+EOL+'WARN'+EOL+'ERROR'+EOL+'FATAL'+EOL+'OFF'+EOL;
 SEVERITY_WARNING    = SEVERITY_WARN; // Synonym for backward compatibility

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.
 LeastPowerOfTwo(x)          Return least power of 2 over x, i.e. minimal value
                             v=2^N with (v>=x). Return 0 in case of overflow.
 }
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;
function  LeastPowerOfTwo(x: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;

 {
 Free and zero MasterObject reference.
 }
function FreeAndZero(var Ref:Integer):Boolean;

 {
 *************************************
 General purpose constants and arrays.
 *************************************
 }
type
 TCharSet        = TSysCharSet;         // set of char;
 TByteSet        = set of Byte;         // set of byte;
 PureString      = ShortString;         // String[255];
 LongString      = RawByteString;       // AnsiString;

type
 PParsingBuffer  = ^TParsingBuffer;
 PMaxPathBuffer  = ^TMaxPathBuffer;
 TParsingBuffer  = packed array[0..255] of Char;
 TMaxPathBuffer  = packed array[0..MAX_PATH-1] of Char;

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

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

type                              // windows compatible types
 LPDWORD         = pdword;        //
 LANGID          = word;          //
 LCID            = 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;

 {
 SysLogXXX     - system logger mechanism.
 SysLogNote    - method to add important system events to log.
 SysLogNotable - checks severity is significant enough to log.
 }
function SysLogErrorCounter:SizeInt;
function SysLogNotable(Severity:Integer):Boolean;
function SysLogNote(TimeStamp:Double; Severity:Integer;
                    const Sender,Body:LongString):Integer;
type
 TSysLogNotableCallback=function(Severity:Integer):Boolean;
 TSysLogNoteCallback=function(TimeStamp:Double; Severity:Integer;
                              const Sender,Body:LongString):Integer;

const // SysLog system callbacks
 TheSysLogNotableCallback:TSysLogNotableCallback=nil;
 TheSysLogNoteCallback:TSysLogNoteCallback=nil;

const // Severity levels for some known SysLog channels
 SeverityOfEchoBugs    : Integer = 0; // SysLog severity of EEchoException
 SeverityOfSoftBugs    : Integer = 0; // SysLog severity of ESoftException
 SeverityOfHarmBugs    : Integer = 0; // SysLog severity of EHarmException
 SeverityOfWatchdog    : Integer = 0; // SysLog severity of TPolling Watchdog
 SeverityOfMistimes    : Integer = 0; // SysLog severity of Mistiming Service
 SeverityOfDaqPrint    : Integer = 0; // DAQ Console Echo
 SeverityOfSysPrint    : Integer = 0; // System Console Output
 SeverityOfSysInput    : Integer = 0; // System Console Input
 SeverityOfSysVoice    : Integer = 0; // Sound Blaster
 SeverityOfTooltips    : Integer = 0; // Tooltip notifier
 SeverityOfSysLogin    : Integer = 0; // Session login/logout
 SeverityOfXLibBugs    : Integer = 0; // XLib errors
 SeverityOfXLibFail    : Integer = 0; // XLib IO errors
 SeverityOfDaqWatchdog : Integer = 0; // DAQ device watchdog deadline
 SeverityOfDaqRunError : Integer = 0; // DAQ Pascal program runtime error
 SeverityOfDaqCompiler : Integer = 0; // DAQ Pascal program runtime error

const // Known SysLog Sender values
 sdr_System   : LongString = 'System'; // System level code
 sdr_SysPrint : LongString = 'Print';  // MainConsole Output
 sdr_SysInput : LongString = 'Input';  // MainConsole Input
 sdr_SysSound : LongString = 'Sound';  // Sound Blaster
 sdr_SysXLib  : LongString = 'XLib';   // XLib, i.e. Unix X Window
 sdr_SysDAQ   : LongString = 'DAQ';    // DAQ System

 {
 *************************************************
 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;
function StringBuffer(const Source:LongString):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;
{$IF SizeOf(Extended)<>SizeOf(Double)}
procedure ExchangeVar(var a,b:Extended); overload;
{$ENDIF}
procedure ExchangeVar(var a,b:ShortString); overload;
procedure ExchangeVar(var a,b:LongString); overload;

 {
 Fake NOP (no operation).
 May be used with variables to avoid compiler hints.
 }
procedure FakeNOP;               overload;
procedure FakeNOP(x:Char);       overload;
procedure FakeNOP(x:Boolean);    overload;
procedure FakeNOP(x:LongInt);    overload;
procedure FakeNOP(x:Double);     overload;
procedure FakeNOP(x:LongString); overload;
procedure FakeNOP(x:TObject);    overload;

 {
 Generate unique number associated with Prefix.
 Each Prefix has own unique number sequence.
 }
function UniqNumberGenerator(const Prefix:LongString):PtrUInt;

 {
 ***************************************
 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;
  myUniqCode : PtrUInt;
  function    GetOk:Boolean;
  function    GetRef:Integer;
  function    GetExceptions:Boolean;
  procedure   SetExceptions(aExcepts:Boolean);
  procedure   SetErrorReportProc(const aProc:TBugReportProc);
  function    GetUniqName:LongString;
  function    GetUniqCode:PtrUInt;
 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;
  property    UniqName        : LongString     read  GetUniqName;
  property    UniqCode        : PtrUInt        read  GetUniqCode;
 end;

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

 {
 TSysCriticalSection - the safe wrapper for TRTLCriticalSection.
 }
type
 TSysCriticalSection = _crw_critsect.TSysCriticalSection;

procedure InitCriticalSection(var cs:TSysCriticalSection);
procedure DoneCriticalSection(var cs:TSysCriticalSection);
procedure EnterCriticalSection(var cs:TSysCriticalSection);
procedure LeaveCriticalSection(var cs:TSysCriticalSection);
function  TryEnterCriticalSection(var cs:TSysCriticalSection):Boolean;
function  SetCriticalSectionSpinCount(var cs:TSysCriticalSection; aCount:Cardinal):Cardinal;

 {
 TLatch incapsulate Windows critical sections in multithread applications.
 }
type
 TLatch = class(TMasterObject)
 private
  myLatch   : TSysCriticalSection;
 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;

const
 SystemSpinLockCount  : Integer = -1; // SpinCount uses by system
 DefaultSpinLockCount : Integer = -1; // SpinCount to use by TLatch

 {
 ***************************************************
 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;
 public
  function ref_min:Integer;
  function ref_max:Integer;
 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(const FileName:LongString):LongString;

type
 TReadTextLinesFromFileCallback=function(const FileName:LongString):LongString;
const
 _ReadTextLinesFromFileCallback:TReadTextLinesFromFileCallback=nil;

 {
 *******************************************************************************
 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                 | Target         |
 |-----------------------|-----------------------|----------------|
 *******************************************************************************
 }
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}
function LockedSet(var Target:LongInt; Value:LongInt):LongInt; overload;
function LockedSet(var Target:Cardinal; Value:Cardinal):Cardinal; overload;
{$IFDEF CPU64}
function LockedSet(var Target:SizeInt; Value:SizeInt):SizeInt; overload;
function LockedSet(var Target:SizeUInt; Value:SizeUInt):SizeUInt; overload;
{$ENDIF}
procedure LockedInit(var Target:LongInt);        overload;
procedure LockedInit(var Target:Cardinal);       overload;
{$IFDEF CPU64}
procedure LockedInit(var Target:SizeInt);        overload;
procedure LockedInit(var Target:SizeUInt);       overload;
{$ENDIF}
procedure LockedFree(var Target:LongInt);        overload;
procedure LockedFree(var Target:Cardinal);       overload;
{$IFDEF CPU64}
procedure LockedFree(var Target:SizeInt);        overload;
procedure LockedFree(var Target:SizeUInt);       overload;
{$ENDIF}

 {
 *******************************************************************************
 Atomic Counters support: safe counters.
 *******************************************************************************
 }
type
 TAtomicCounter = _crw_atomic.TAtomicCounter;

function LockedAdd(var Target:TAtomicCounter; Value:SizeInt):SizeInt; overload;
function LockedCompareExchange(var Target:TAtomicCounter; Exch, Comp: SizeInt):SizeInt; overload;
function LockedDec(var Target:TAtomicCounter):SizeInt; overload;
function LockedExchange(var Target:TAtomicCounter; Value:SizeInt):SizeInt; overload;
function LockedExchangeAdd(var Target:TAtomicCounter; Value:SizeInt):SizeInt; overload;
function LockedExchangeDec(var Target:TAtomicCounter):SizeInt; overload;
function LockedExchangeInc(var Target:TAtomicCounter):SizeInt; overload;
function LockedExchangeSub(var Target:TAtomicCounter; Value:SizeInt):SizeInt; overload;
function LockedInc(var Target:TAtomicCounter):SizeInt; overload;
function LockedSub(var Target:TAtomicCounter; Value:SizeInt):SizeInt; overload;
function LockedGet(var Target:TAtomicCounter):SizeInt; overload;
function LockedSet(var Target:TAtomicCounter; Value:SizeInt):SizeInt; overload;
procedure LockedInit(var Target:TAtomicCounter); overload;
procedure LockedFree(var Target:TAtomicCounter); overload;
function Test_LockedCounters(const a,b:SizeInt):LongString;

var SystemThreadManager:TThreadManager; // Initial ThreadManager

implementation

function IsFpc     : Boolean; begin Result := {$IFDEF FPC}           true {$ELSE} false {$ENDIF}; end;
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 OsName(Mode:Integer=1):String;
begin
 case Mode of
  1: begin
   if IsUnix then Result:='Unix' else
   if IsWindows then Result:='Windows' else Result:='Unknown';
  end;
  2: begin
   if IsLinux then Result:='Linux' else
   if IsUnix then Result:='Unix' else
   if IsWindows then Result:='Windows' else Result:='Unknown';
  end;
  else Result:='';
 end;
end;

function GetFpcVersion:String;
begin
 Result:={$I %FPCVERSION%};
end;

function GetFpcTargetOS:String;
begin
 Result:={$I %FPCTARGETOS%};
end;

function GetFpcTargetCPU:String;
begin
 Result:={$I %FPCTARGETCPU%};
end;

function GetFpcTargetPlatform:String;
begin
 Result:={$I %FPCTARGETCPU%}+'-'+{$I %FPCTARGETOS%};
end;

function GetLastOsError:LongInt;
begin
 {$IFDEF WINDOWS}
 Result:=GetLastError;
 {$ENDIF ~WINDOWS}
 {$IFDEF UNIX}
 Result:=fpgeterrno;
 {$ENDIF ~UNIX}
end;

procedure SetLastOsError(err:LongInt);
begin
 {$IFDEF WINDOWS}
 SetLastError(err);
 {$ENDIF ~WINDOWS}
 {$IFDEF UNIX}
 fpseterrno(err);
 {$ENDIF ~UNIX}
end;

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

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

function GetAllocMemCount:SizeInt;
begin
 with ShareMemStorage do if ExtMM_Enabled then Exit(ExtMM_Allocated);
 Result:=GetHeapStatus.TotalAllocated;
end;

function GetAllocMemSize:SizeInt;
begin
 with ShareMemStorage do if ExtMM_Enabled then Exit(ExtMM_Allocated);
 Result:=GetHeapStatus.TotalAllocated;
end;

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

const
 SysLogCntr:TAtomicCounter=nil;

procedure Init_SysLog;
begin
 LockedInit(SysLogCntr);
end;

procedure Free_SysLog;
begin
 LockedFree(SysLogCntr);
end;

procedure SysLogBug(E:Exception);
begin
 LockedInc(SysLogCntr);
 if not Assigned(E) then Exit;
 Echo('SysLog: Exception '+E.ClassName+' - '+E.Message);
end;

function SysLogErrorCounter:SizeInt;
begin
 Result:=LockedGet(SysLogCntr);
end;

function SysLogNotable(Severity:Integer):Boolean;
begin
 Result:=False;
 if Assigned(TheSysLogNotableCallback) then
 try
  Result:=TheSysLogNotableCallback(Severity);
 except
  on E:Exception do SysLogBug(E);
 end;
end;

function SysLogNote(TimeStamp:Double; Severity:Integer;
                    const Sender,Body:LongString):Integer;
begin
 Result:=0;
 if Assigned(TheSysLogNoteCallback) then
 try
  Result:=TheSysLogNoteCallback(TimeStamp,Severity,Sender,Body);
 except
  on E:Exception do SysLogBug(E);
 end;
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;

function StringBuffer(const Source:LongString):LongString;
begin
 if (Source<>'')
 then Result:=StringBuffer(PChar(Source),Length(Source))
 else Result:='';
end;

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

procedure InitBornKillCounters;
begin
 LockedInit(AllocMemBalance);
 LockedInit(AllocateBalance);
 LockedInit(BornKillBalance);
 LockedInit(AllocErrorCount);
end;

procedure FreeBornKillCounters;
begin
 LockedFree(AllocMemBalance);
 LockedFree(AllocateBalance);
 LockedFree(BornKillBalance);
 LockedFree(AllocErrorCount);
end;

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
 InitBornKillCounters;
 LockedSet(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
 LockedSet(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]));
 FreeBornKillCounters;
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;

function LeastPowerOfTwo(x:SizeInt):SizeInt;
begin
 Result:=1;
 while (Result<x) and (Result>0) do Result:=Result shl 1;
 if (Result<=0) then Result:=0;
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;

function FreeAndZero(var Ref:Integer):Boolean;
var Obj:TObject; ObjRef:Integer;
begin
 Result:=False;
 ObjRef:=LockedExchange(Ref,0);
 if (ObjRef=0) then Exit(True);
 try
  Obj:=ObjectRegistry[ObjRef];
  if (Obj is TMasterObject) then begin
   FreeAndNil(Obj);
   Result:=True;
  end;
 except
  on E:Exception do BugReport(E,nil,'FreeAndZero');
 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;

{$IF SizeOf(Extended)<>SizeOf(Double)}
procedure ExchangeVar(var a,b:Extended); overload;
var Temp:Extended;
begin
 Temp:=a; a:=b; b:=Temp;
end;
{$ENDIF}

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;

 {
 Fake NOP (no operation).
 }
procedure FakeNOP;               begin end;
procedure FakeNOP(x:Char);       begin end;
procedure FakeNOP(x:Boolean);    begin end;
procedure FakeNOP(x:LongInt);    begin end;
procedure FakeNOP(x:Double);     begin end;
procedure FakeNOP(x:LongString); begin end;
procedure FakeNOP(x:TObject);    begin end;

 {
 **********************************
 UniqNumberGenerator implementation
 **********************************
 }

type
 TUniqNumGen = class(TObject)
 private
  myNumber : PtrUInt;
 public
  function TakeUniqNumber:PtrUInt;
 end;

function TUniqNumGen.TakeUniqNumber:PtrUInt;
begin
 if Assigned(Self)
 then Result:=LockedInc(myNumber)-1
 else Result:=0;
end;

const
 UniqNumGenCrit:TSysCriticalSection=nil;
 UniqNumGenList:TStringList=nil;

procedure InitUniqNumGenList;
begin
 InitCriticalSection(UniqNumGenCrit);
 UniqNumGenList:=TStringList.Create;
 UniqNumGenList.Duplicates:=dupIgnore;
 UniqNumGenList.OwnsObjects:=True;
 UniqNumGenList.UseLocale:=False;
 UniqNumGenList.Sorted:=True;
end;

procedure FreeUniqNumGenList;
begin
 try
  EnterCriticalSection(UniqNumGenCrit);
  try
   Kill(UniqNumGenList);
  finally
   LeaveCriticalSection(UniqNumGenCrit);
  end;
  DoneCriticalSection(UniqNumGenCrit);
 except
  on E:Exception do BugReport(E,nil,'FreeUniqNumGenList');
 end;
end;

function UniqNumberGenerator(const Prefix:LongString):PtrUInt;
var i:Integer; Item:TUniqNumGen; Obj:TObject;
begin
 Result:=0;
 if (Prefix<>'') then
 try
  EnterCriticalSection(UniqNumGenCrit);
  try
   i:=UniqNumGenList.IndexOf(Prefix);
   if (i<0) then begin
    Item:=TUniqNumGen.Create;
    UniqNumGenList.AddObject(Prefix,Item);
    Result:=Item.TakeUniqNumber;
   end else begin
    Obj:=UniqNumGenList.Objects[i];
    if (Obj is TUniqNumGen) then begin
     Item:=TUniqNumGen(Obj);
     Result:=Item.TakeUniqNumber;
    end;
   end;
  finally
   LeaveCriticalSection(UniqNumGenCrit);
  end;
 except
  on E:Exception do BugReport(E,nil,'UniqNumberGenerator');
 end;
end;

 {
 ****************************
 TMasterObject implementation
 ****************************
 }
constructor TMasterObject.Create;
begin
 inherited Create;
 myMaster:=nil;
 myExcepts:=false;
 myReporter:=@DefaultObjectErrorReportProc;
 myUniqCode:=UniqNumberGenerator(ClassName);
end;

procedure TMasterObject.AfterConstruction;
begin
 inherited AfterConstruction;
 if UsesBornKillLog
 then BornKillLog(Format('BORN %-25s %8.8x %8.8x %d',
                  [ClassName, IntPtr(Self), GetCurrentThreadID, GetBornKillBalance]));
 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, GetBornKillBalance]));
 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;

function TMasterObject.GetUniqName:LongString;
begin
 Result:='';
 if Assigned(Self) then begin
  Result:=ClassName;
  if (Length(Result)>1) then
  if (Result[1] in ['T','t']) then Delete(Result,1,1);
  if (myUniqCode<>0) then Result+=Format('%u',[myUniqCode]);
 end;
end;

function TMasterObject.GetUniqCode:PtrUInt;
begin
 if Assigned(Self)
 then Result:=myUniqCode
 else Result:=0;
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;

 {
 *****************************
 TSysCriticalSections routines
 *****************************
 }

procedure InitCriticalSection(var cs:TSysCriticalSection);
begin
 InitSysCriticalSection(cs);
end;

procedure DoneCriticalSection(var cs:TSysCriticalSection);
begin
 Kill(cs);
end;

procedure EnterCriticalSection(var cs:TSysCriticalSection);
begin
 cs.Enter;
end;

procedure LeaveCriticalSection(var cs:TSysCriticalSection);
begin
 cs.Leave;
end;

function  TryEnterCriticalSection(var cs:TSysCriticalSection):Boolean;
begin
 Result:=cs.TryEnter;
end;

function SetCriticalSectionSpinCount(var cs:TSysCriticalSection; aCount:Cardinal):Cardinal;
begin
 Result:=cs.SetSpinCount(aCount);
end;

 {
 *********************
 TLatch implementation
 *********************
 }
const
 LockUnlockBalance : TAtomicCounter = nil;

procedure InitLatchCounters;
begin
 LockedInit(LockUnlockBalance);
end;

procedure FreeLatchCounters;
begin
 LockedFree(LockUnlockBalance);
end;

constructor TLatch.Create;
begin
 inherited Create;
 InitCriticalSection(myLatch);
 {$IFDEF WINDOWS}
 if (DefaultSpinLockCount>=0)
 then SetCriticalSectionSpinCount(myLatch,DefaultSpinLockCount);
 {$ENDIF ~WINDOWS}
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;

{$IFDEF WINDOWS}
var
 FakeCritSec:TSysCriticalSection=nil;
{$ENDIF ~WINDOWS}

procedure InitSystemSpinLockCount;
begin
 {$IFDEF WINDOWS}
 InitCriticalSection(FakeCritSec);
 SystemSpinLockCount:=SetCriticalSectionSpinCount(FakeCritSec,0);
 DoneCriticalSection(FakeCritSec);
 {$ENDIF ~WINDOWS}
end;

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

procedure InitObjectRegistry;
begin
 LockedInit(ErrObjectRegistry);
 ObjectRegistry.Ok;
end;

procedure FreeObjectRegistry;
begin
 TheObjectRegistry.Free;
 LockedFree(ErrObjectRegistry);
end;

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.ref_min:Integer;
begin
 if Assigned(Self)
 then Result:=ObjectRegistryOffset
 else Result:=0;
end;

function TObjectRegistry.ref_max:Integer;
begin
 if Assigned(Self)
 then Result:=ObjectRegistryOffset+Capacity-1
 else Result:=0;
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);
    if SysLogNotable(SeverityOfEchoBugs)
    then SysLogNote(0,SeverityOfEchoBugs,sdr_System,E.ClassName+' - '+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+Who+Note+Why);
    if SysLogNotable(SeverityOfSoftBugs)
    then SysLogNote(0,SeverityOfSoftBugs,sdr_System,What+Who+Note+Why);
    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 begin
    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);
    if SysLogNotable(SeverityOfHarmBugs)
    then SysLogNote(0,SeverityOfHarmBugs,sdr_System,What+Who+Note+Why+' '+Info);
   end;
  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 : TSysCriticalSection = nil;

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(const 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
  if Assigned(_ReadTextLinesFromFileCallback) then begin
   Result:=_ReadTextLinesFromFileCallback(FileName);
   Result:=AdjustLineBreaks(Result);
   Exit;
  end;
  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}

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

 {
 ******************************
 Atomic Counters implementation
 ******************************
 }
function LockedAdd(var Target:TAtomicCounter; Value:SizeInt):SizeInt;
begin
 if (Target=nil) then InitAtomicCounter(Target);
 Result:=Target.LockedAdd(Value);
end;

function LockedCompareExchange(var Target:TAtomicCounter; Exch, Comp: SizeInt):SizeInt;
begin
 if (Target=nil) then InitAtomicCounter(Target);
 Result:=Target.LockedCompareExchange(Exch,Comp);
end;

function LockedDec(var Target:TAtomicCounter):SizeInt;
begin
 if (Target=nil) then InitAtomicCounter(Target);
 Result:=Target.LockedDec;
end;

function LockedExchange(var Target:TAtomicCounter; Value:SizeInt):SizeInt;
begin
 if (Target=nil) then InitAtomicCounter(Target);
 Result:=Target.LockedExchange(Value);
end;

function LockedExchangeAdd(var Target:TAtomicCounter; Value:SizeInt):SizeInt;
begin
 if (Target=nil) then InitAtomicCounter(Target);
 Result:=Target.LockedExchangeAdd(Value);
end;

function LockedExchangeDec(var Target:TAtomicCounter):SizeInt;
begin
 if (Target=nil) then InitAtomicCounter(Target);
 Result:=Target.LockedExchangeDec;
end;

function LockedExchangeInc(var Target:TAtomicCounter):SizeInt;
begin
 if (Target=nil) then InitAtomicCounter(Target);
 Result:=Target.LockedExchangeInc;
end;

function LockedExchangeSub(var Target:TAtomicCounter; Value:SizeInt):SizeInt;
begin
 if (Target=nil) then InitAtomicCounter(Target);
 Result:=Target.LockedExchangeSub(Value);
end;

function LockedInc(var Target:TAtomicCounter):SizeInt;
begin
 if (Target=nil) then InitAtomicCounter(Target);
 Result:=Target.LockedInc;
end;

function LockedSub(var Target:TAtomicCounter; Value:SizeInt):SizeInt;
begin
 if (Target=nil) then InitAtomicCounter(Target);
 Result:=Target.LockedSub(Value);
end;

function LockedGet(var Target:TAtomicCounter):SizeInt;
begin
 if (Target=nil) then InitAtomicCounter(Target);
 Result:=Target.LockedGet;
end;

function LockedSet(var Target:TAtomicCounter; Value:SizeInt):SizeInt;
begin
 if (Target=nil) then InitAtomicCounter(Target);
 Result:=Target.LockedSet(Value);
end;

procedure LockedInit(var Target:TAtomicCounter); begin LockedSet(Target,0); end;
procedure LockedInit(var Target:LongInt);        begin LockedSet(Target,0); end;
procedure LockedInit(var Target:Cardinal);       begin LockedSet(Target,0); end;
{$IFDEF CPU64}
procedure LockedInit(var Target:SizeInt);        begin LockedSet(Target,0); end;
procedure LockedInit(var Target:SizeUInt);       begin LockedSet(Target,0); end;
{$ENDIF}

procedure LockedFree(var Target:TAtomicCounter); begin Kill(Target); end;
procedure LockedFree(var Target:LongInt);        begin               end;
procedure LockedFree(var Target:Cardinal);       begin               end;
{$IFDEF CPU64}
procedure LockedFree(var Target:SizeInt);        begin               end;
procedure LockedFree(var Target:SizeUInt);       begin               end;
{$ENDIF}

function Test_LockedCounters(const a,b:SizeInt):LongString;
const ac:TAtomicCounter=nil;
 function Test1(op:LongString; a,v,e:SizeInt):LongString;
 begin
  Result:=Format('%s(%d) = %d, expect %d',[op,a,v,e]);
 end;
 function Test2(op:LongString; a,b,v,e:SizeInt):LongString;
 begin
  Result:=Format('%s(%d,%d) = %d, expect %d',[op,a,b,v,e]);
 end;
begin
 Result:=Format('Test LockedCounters(%d,%d):',[a,b])+EOL;
 LockedInit(ac);
 if (ac=nil) then Result:=Result+'Error: invalid Init.'+EOL;
 Result:=Result+Test1('Set',a,LockedSet(ac,a),0)+EOL;
 Result:=Result+Test1('Inc',a,LockedInc(ac),a+1)+EOL;
 Result:=Result+Test1('Get',a+1,LockedGet(ac),a+1)+EOL;
 Result:=Result+Test1('Dec',a+1,LockedDec(ac),a)+EOL;
 Result:=Result+Test2('Add',a,b,LockedAdd(ac,b),a+b)+EOL;
 Result:=Result+Test2('Sub',a+b,b,LockedSub(ac,b),a)+EOL;
 Result:=Result+Format('TAtomicCounter.Population: %d',[TAtomicCounter.Population])+EOL;
 LockedFree(ac);
 if (ac<>nil) then Result:=Result+'Error: invalid Free.'+EOL;
 Result:=Result+'Done.'+EOL;
end;

 {
 Utilities
 }
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
 InitSystemSpinLockCount;
 SaveSystemThreadManager;
 OnGetVendorName:=crwGetVendorNameEvent;
 InitCriticalSection(SafeFileWriteStrLatch);
 InitUniqNumGenList;
 Init_SysLog;
 InitBornKillLog;
 InitLatchCounters;
 InitObjectRegistry;
end;

procedure Free_crw_alloc;
begin
 ResourceLeakageLog(Format('%-60s = %d',['Balance of TLatch.Lock/Unlock',LockedGet(LockUnlockBalance)]));
 ResourceLeakageLog(Format('%-60s = %d',['ObjectRegistry.Errors',LockedGet(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]));
 ResourceLeakageLog(Format('%-60s = %d',['SysLogErrorCounter',SysLogErrorCounter]));
 FreeObjectRegistry;
 FreeLatchCounters;
 DoneBornKillLog;
 Free_SysLog;
 FreeUniqNumGenList;
 ResourceLeakageLog(Format('%-60s = %d',['TSysCriticalSection.Population',TSysCriticalSection.Population-1]));
 ResourceLeakageLog(Format('%-60s = %d',['TAtomicCounter.Population',TAtomicCounter.Population]));
 DoneCriticalSection(SafeFileWriteStrLatch);
end;

initialization

 Init_crw_alloc;

finalization

 Free_crw_alloc;

end.

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

