Delphi/delphimvcframework
1
0
Fork 0
mirror of https://github.com/danieleteti/delphimvcframework.git synced 2024-11-15 15:55:54 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity
9edc977bc4
delphimvcframework/lib/dmustache/mormot.core.base.pas

12239 lines
379 KiB
ObjectPascal
Raw Normal View History

Updated dmustache to version 2
2024-04-29 15:40:45 +02:00
/// Framework Core Shared Types and RTL-like Functions
// - this unit is a part of the Open Source Synopse mORMot framework 2,
// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
unit mormot.core.base;
{
*****************************************************************************
Basic types and reusable stand-alone functions shared by all framework units
- Framework Version and Information
- Common Types Used for Compatibility Between Compilers and CPU
- Numbers (floats and integers) Low-level Definitions
- Integer Arrays Manipulation
- ObjArray PtrArray InterfaceArray Wrapper Functions
- Low-level Types Mapping Binary or Bits Structures
- Buffers (e.g. Hashing and SynLZ compression) Raw Functions
- Efficient Variant Values Conversion
- Sorting/Comparison Functions
- Some Convenient TStream descendants and File access functions
- Faster Alternative to RTL Standard Functions
- Raw Shared Constants / Types Definitions
Aim of those types and functions is to be cross-platform and cross-compiler,
without any dependency but the main FPC/Delphi RTL. It also detects the
kind of CPU it runs on, to adapt to the fastest asm version available.
It is the main unit where x86_64 or i386 asm stubs are included.
*****************************************************************************
}
interface
{$I mormot.defines.inc}
uses
variants,
classes,
contnrs,
types,
sysutils;
{ ************ Framework Version and Information }
const
/// the full text of the Synopse mORMot framework
// - note: we don't supply full version number with build revision for
// HTTP servers, to reduce potential attack surface
SYNOPSE_FRAMEWORK_NAME = 'mORMot';
/// the corresponding version of the mORMot framework, as '2.#.#'
// - 2nd digit is minor version, increased at each framework release,
// when adding functionality in a stable enough manner
// - 3rd digit is a globally increasing git commit number (as generated by the
// commit.sh script) - so won't be reset when minor is up
SYNOPSE_FRAMEWORK_VERSION = {$I mormot.commit.inc};
/// a text including the version and the main active conditional options
// - usefull for low-level debugging purpose
SYNOPSE_FRAMEWORK_FULLVERSION = SYNOPSE_FRAMEWORK_VERSION
{$ifdef FPC}
{$ifdef FPC_X64MM} + ' x64MM'
{$ifdef FPCMM_BOOST} + 'b' {$endif}
{$ifdef FPCMM_SERVER} + 's' {$endif}
{$else}
{$ifdef FPC_LIBCMM} + ' CM' {$endif}
{$endif FPC_X64MM}
{$else}
{$ifdef FullDebugMode} + ' FDM' {$endif}
{$endif FPC};
{ ************ Common Types Used for Compatibility Between Compilers and CPU }
const
/// internal Code Page for UTF-8 Unicode encoding
// - as used by RawUtf8 and all our internal framework text process
CP_UTF8 = 65001;
/// internal Code Page for UTF-16 Unicode encoding
// - used e.g. for Delphi 2009+ UnicodeString=String type
CP_UTF16 = 1200;
/// internal Code Page for RawByteString undefined string
CP_RAWBYTESTRING = 65535;
/// fake code page used to recognize RawBlob
// - RawBlob internal code page will be CP_RAWBYTESTRING = 65535, but our ORM
// will identify the RawBlob type and unserialize it using CP_RAWBLOB instead
// - TJsonWriter.AddAnyAnsiBuffer will recognize it and use Base-64 encoding
CP_RAWBLOB = 65534;
/// US English Windows Code Page, i.e. WinAnsi standard character encoding
CP_WINANSI = 1252;
/// Latin-1 ISO/IEC 8859-1 Code Page
// - map low 8-bit Unicode CodePoints
CP_LATIN1 = 819;
/// internal Code Page for System AnsiString encoding
CP_ACP = 0;
/// internal Code Page for System Console encoding
CP_OEM = 1;
/// use rather CP_WINANSI with mORMot 2
CODEPAGE_US = CP_WINANSI;
/// use rather CP_LATIN1 with mORMot 2
CODEPAGE_LATIN1 = CP_LATIN1;
{$ifdef FPC} { make cross-compiler and cross-CPU types available to Delphi }
type
PBoolean = ^boolean;
{$else FPC}
type
{$ifdef CPU64} // Delphi XE2 seems stable about those types (not Delphi 2009)
PtrInt = NativeInt;
PtrUInt = NativeUInt;
{$else}
/// a CPU-dependent signed integer type cast of a pointer / register
// - used for 64-bit compatibility, native under Free Pascal Compiler
PtrInt = integer;
/// a CPU-dependent unsigned integer type cast of a pointer / register
// - used for 64-bit compatibility, native under Free Pascal Compiler
PtrUInt = cardinal;
{$endif CPU64}
/// a CPU-dependent unsigned integer type cast of a pointer of pointer
// - used for 64-bit compatibility, native under Free Pascal Compiler
PPtrUInt = ^PtrUInt;
/// a CPU-dependent signed integer type cast of a pointer of pointer
// - used for 64-bit compatibility, native under Free Pascal Compiler
PPtrInt = ^PtrInt;
/// unsigned Int64 doesn't exist under older Delphi, but is defined in FPC
// - and UInt64 is buggy as hell under Delphi 2007 when inlining functions:
// older compilers will fallback to signed Int64 values
// - anyway, consider using SortDynArrayQWord() to compare QWord values
// in a safe and efficient way, under a CPUX86
// - use UInt64 explicitly in your computation (like in mormot.crypt.ecc),
// if you are sure that Delphi 6-2007 compiler handles your code as expected,
// but mORMot code will expect to use QWord for its internal process
// (e.g. ORM/SOA serialization)
{$ifdef UNICODE}
QWord = UInt64;
{$else}
QWord = type Int64;
{$endif UNICODE}
/// points to an unsigned Int64
PQWord = ^QWord;
// redefined here to not use the unexpected PWord definition from Windows unit
PWord = System.PWord;
// redefined here to not use the unexpected PSingle definition from Windows unit
PSingle = System.PSingle;
// this pointer is not defined on older Delphi revisions
PMethod = ^TMethod;
{$ifndef ISDELPHIXE2}
/// used to store the handle of a system Thread
TThreadID = cardinal;
/// compatibility definition with FPC and newer Delphi
PUInt64 = ^UInt64;
{$endif ISDELPHIXE2}
{$endif FPC}
type
/// RawUtf8 is an UTF-8 String stored in an AnsiString, alias to System.UTF8String
// - all conversion to/from string or WinAnsiString must be explicit on
// Delphi 7/2007, and it will be faster anyway to use our optimized functions
// from mormot.core.unicode.pas unit like StringToUtf8/Utf8ToString
RawUtf8 = System.UTF8String; // CP_UTF8 Codepage
/// a RawUtf8 value which may contain Sensitive Personal Information
// (e.g. a bank card number or a plain password)
// - identified as a specific type e.g. to be hidden in the logs - when the
// woHideSensitivePersonalInformation TTextWriterWriteObjectOption is set
SpiUtf8 = type RawUtf8;
/// WinAnsiString is a WinAnsi-encoded AnsiString (code page 1252)
// - use this type instead of System.String, which behavior changed
// between Delphi 2009 compiler and previous versions: our implementation
// is consistent and compatible with all versions of Delphi compiler
// - all conversion to/from string or RawUtf8/UTF8String must be explicit on
// Delphi 7/2007, and it will be faster anyway to use our optimized functions
// from mormot.core.unicode.pas unit like StringToUtf8/Utf8ToString
{$ifdef HASCODEPAGE}
WinAnsiString = type AnsiString(CP_WINANSI); // WinAnsi 1252 Codepage
{$else}
WinAnsiString = type AnsiString;
{$endif HASCODEPAGE}
{$ifdef HASCODEPAGE}
{$ifdef FPC}
// missing declaration
PRawByteString = ^RawByteString;
{$endif FPC}
{$else}
/// define RawByteString, as it does exist in Delphi 2009+
// - to be used for byte storage into an AnsiString
// - use this type if you don't want the Delphi compiler not to do any
// code page conversions when you assign a typed AnsiString to a RawByteString,
// i.e. a RawUtf8 or a WinAnsiString
RawByteString = type AnsiString;
/// pointer to a RawByteString
PRawByteString = ^RawByteString;
{$endif HASCODEPAGE}
/// RawJson will indicate that this variable content would stay as raw JSON
// - i.e. won't be serialized into values
// - could be any JSON content: number, boolean, null, string, object or array
// - e.g. interface-based service will use it for efficient and AJAX-ready
// transmission of TOrmTableJson result
RawJson = type RawUtf8;
/// a RawByteString sub-type used to store the BLOB content in our ORM
// - equals RawByteString for byte storage
// - TRttiInfo.AnsiStringCodePage will identify this type, and return
// CP_RAWBLOB fake codepage for such a published property, even if it is
// just an alias to CP_RAWBYTESTRING
// - our ORM will therefore identify such properties as BLOB
// - by default, the BLOB fields are not retrieved or updated with raw
// TRest.Retrieve() method, that is "Lazy loading" is enabled by default
// for blobs, unless TRestClientUri.ForceBlobTransfert property is TRUE
// (for all tables), or ForceBlobTransfertTable[] (for a particular table);
// so use RetrieveBlob() methods for handling BLOB fields
// - could be defined as value in a TOrm property as such:
// ! property Blob: RawBlob read fBlob write fBlob;
// - is defined here for proper TRttiProp.WriteAsJson serialization
RawBlob = type RawByteString;
/// SynUnicode is the fastest available Unicode native string type, depending
// on the compiler used
// - this type is native to the compiler, so you can use Length() Copy() and
// such functions with it (this is not possible with RawUnicodeString type)
// - before Delphi 2009+, it uses slow OLE compatible WideString
// (with our Enhanced RTL, WideString allocation can be made faster by using
// an internal caching mechanism of allocation buffers - WideString allocation
// has been made much faster since Windows Vista/Seven)
// - starting with Delphi 2009, it uses the faster UnicodeString type, which
// allow Copy On Write, Reference Counting and fast heap memory allocation
// - on recent FPC, HASVARUSTRING is defined and native UnicodeString is set
{$ifdef HASVARUSTRING}
SynUnicode = UnicodeString;
{$else}
SynUnicode = WideString;
{$endif HASVARUSTRING}
{$ifndef PUREMORMOT2}
/// low-level RawUnicode as an Unicode String stored in an AnsiString
// - DEPRECATED TYPE, introduced in Delphi 7/2007 days: SynUnicode is to be used
// - faster than WideString, which are allocated in Global heap (for COM)
// - an AnsiChar(#0) is added at the end, for having a true WideChar(#0) at ending
// - length(RawUnicode) returns memory bytes count: use (length(RawUnicode) shr 1)
// for WideChar count (that's why the definition of this type since Delphi 2009
// is AnsiString(1200) and not UnicodeString)
// - pointer(RawUnicode) is compatible with Win32 'Wide' API call
// - mimic Delphi 2009 UnicodeString, without the WideString or Ansi conversion overhead
// - all conversion to/from AnsiString or RawUtf8 must be explicit: the
// compiler may not be able to perform implicit conversions on CP_UTF16
{$ifdef HASCODEPAGE}
RawUnicode = type AnsiString(CP_UTF16); // Codepage for an "Unicode" String
{$else}
RawUnicode = type AnsiString;
{$endif HASCODEPAGE}
PRawUnicode = ^RawUnicode;
{$endif PUREMORMOT2}
/// low-level storage of UCS4 CodePoints, stored as 32-bit integers
RawUcs4 = TIntegerDynArray;
/// store one 32-bit UCS4 CodePoint (with a better naming than UCS4 "Char")
// - RTL's Ucs4Char is buggy, especially on oldest Delphi
Ucs4CodePoint = cardinal;
{$ifdef CPU64}
HalfInt = integer;
HalfUInt = cardinal;
{$else}
/// a CPU-dependent signed integer type cast of half a pointer
HalfInt = smallint;
/// a CPU-dependent unsigned integer type cast of half a pointer
HalfUInt = word;
{$endif CPU64}
/// a CPU-dependent signed integer type cast of a pointer to half a pointer
PHalfInt = ^HalfInt;
/// a CPU-dependent unsigned integer type cast of a pointer to half a pointer
PHalfUInt = ^HalfUInt;
PRawJson = ^RawJson;
PPRawJson = ^PRawJson;
PRawUtf8 = ^RawUtf8;
PPRawUtf8 = ^PRawUtf8;
PWinAnsiString = ^WinAnsiString;
PWinAnsiChar = type PAnsiChar;
PSynUnicode = ^SynUnicode;
PFileName = ^TFileName;
/// a simple wrapper to UTF-8 encoded zero-terminated PAnsiChar
// - PAnsiChar is used only for Win-Ansi encoded text
// - the Synopse mORMot framework uses mostly this PUtf8Char type,
// because all data is internally stored and expected to be UTF-8 encoded
PUtf8Char = type PAnsiChar;
PPUtf8Char = ^PUtf8Char;
PPPUtf8Char = ^PPUtf8Char;
/// a Row/Col array of PUtf8Char, for containing sqlite3_get_table() result
TPUtf8CharArray = array[ 0 .. MaxInt div SizeOf(PUtf8Char) - 1 ] of PUtf8Char;
PPUtf8CharArray = ^TPUtf8CharArray;
/// a dynamic array of PUtf8Char pointers
TPUtf8CharDynArray = array of PUtf8Char;
/// a dynamic array of UTF-8 encoded strings
TRawUtf8DynArray = array of RawUtf8;
PRawUtf8DynArray = ^TRawUtf8DynArray;
TRawUtf8DynArrayDynArray = array of TRawUtf8DynArray;
/// a dynamic array of TVarRec, i.e. could match an "array of const" parameter
TTVarRecDynArray = array of TVarRec;
/// a TVarData values array
// - is not called TVarDataArray to avoid confusion with the corresponding
// type already defined in RTL Variants.pas, and used for custom late-binding
TVarDataStaticArray = array[ 0 .. MaxInt div SizeOf(TVarData) - 1 ] of TVarData;
PVarDataStaticArray = ^TVarDataStaticArray;
TVariantArray = array[ 0 .. MaxInt div SizeOf(Variant) - 1 ] of Variant;
PVariantArray = ^TVariantArray;
TVariantDynArray = array of variant;
PPVariant = ^PVariant;
PPVarData = ^PVarData;
PIntegerDynArray = ^TIntegerDynArray;
TIntegerDynArray = array of integer;
TIntegerDynArrayDynArray = array of TIntegerDynArray;
PCardinalDynArray = ^TCardinalDynArray;
TCardinalDynArray = array of cardinal;
PSingleDynArray = ^TSingleDynArray;
TSingleDynArray = array of Single;
PInt64DynArray = ^TInt64DynArray;
TInt64DynArray = array of Int64;
PQwordDynArray = ^TQwordDynArray;
TQwordDynArray = array of Qword;
TPtrUIntDynArray = array of PtrUInt;
THalfUIntDynArray = array of HalfUInt;
PDoubleDynArray = ^TDoubleDynArray;
TDoubleDynArray = array of double;
PCurrencyDynArray = ^TCurrencyDynArray;
TCurrencyDynArray = array of currency;
PExtendedDynArray = ^TExtendedDynArray;
TExtendedDynArray = array of Extended;
TWordDynArray = array of word;
PWordDynArray = ^TWordDynArray;
TByteDynArray = array of byte;
PByteDynArray = ^TByteDynArray;
{$ifndef ISDELPHI2007ANDUP}
TBytes = array of byte;
{$endif ISDELPHI2007ANDUP}
TBytesDynArray = array of TBytes;
PBytesDynArray = ^TBytesDynArray;
TObjectDynArray = array of TObject;
PObjectDynArray = ^TObjectDynArray;
TPersistentDynArray = array of TPersistent;
PPersistentDynArray = ^TPersistentDynArray;
TPointerDynArray = array of pointer;
PPointerDynArray = ^TPointerDynArray;
TPointerDynArrayDynArray = array of TPointerDynArray;
TPPointerDynArray = array of PPointer;
PPPointerDynArray = ^TPPointerDynArray;
TMethodDynArray = array of TMethod;
PMethodDynArray = ^TMethodDynArray;
TObjectListDynArray = array of TObjectList;
PObjectListDynArray = ^TObjectListDynArray;
TFileNameDynArray = array of TFileName;
PFileNameDynArray = ^TFileNameDynArray;
TBooleanDynArray = array of boolean;
PBooleanDynArray = ^TBooleanDynArray;
TClassDynArray = array of TClass;
TWinAnsiDynArray = array of WinAnsiString;
PWinAnsiDynArray = ^TWinAnsiDynArray;
TStringDynArray = array of string;
PStringDynArray = ^TStringDynArray;
PShortStringDynArray = array of PShortString;
PPShortStringArray = ^PShortStringArray;
TShortStringDynArray = array of ShortString;
TDateTimeDynArray = array of TDateTime;
PDateTimeDynArray = ^TDateTimeDynArray;
{$ifndef FPC_OR_UNICODE}
TDate = type TDateTime;
TTime = type TDateTime;
{$endif FPC_OR_UNICODE}
TDateDynArray = array of TDate;
PDateDynArray = ^TDateDynArray;
TTimeDynArray = array of TTime;
PTimeDynArray = ^TTimeDynArray;
TWideStringDynArray = array of WideString;
PWideStringDynArray = ^TWideStringDynArray;
TSynUnicodeDynArray = array of SynUnicode;
PSynUnicodeDynArray = ^TSynUnicodeDynArray;
TRawByteStringDynArray = array of RawByteString;
PRawByteStringDynArray = ^TRawByteStringDynArray;
{$ifdef HASVARUSTRING}
TUnicodeStringDynArray = array of UnicodeString;
PUnicodeStringDynArray = ^TUnicodeStringDynArray;
{$endif HASVARUSTRING}
TRawJsonDynArray = array of RawJson;
PRawJsonDynArray = ^TRawJsonDynArray;
TGuidDynArray = array of TGuid;
PGuidDynArray = array of PGuid;
PObject = ^TObject;
PClass = ^TClass;
PList = ^TList;
PObjectList = ^TObjectList;
PCollection = ^TCollection;
PStrings = ^TStrings;
PPByte = ^PByte;
PPPByte = ^PPByte;
PPInteger = ^PInteger;
PPCardinal = ^PCardinal;
PPPointer = ^PPointer;
PByteArray = ^TByteArray;
TByteArray = array[ 0 .. MaxInt - 1 ] of byte; // redefine here with {$R-}
PBooleanArray = ^TBooleanArray;
TBooleanArray = array[ 0 .. MaxInt - 1 ] of boolean;
PPWord = ^PWord;
TWordArray = array[ 0 .. MaxInt div SizeOf(word) - 1 ] of word;
PWordArray = ^TWordArray;
TIntegerArray = array[ 0 .. MaxInt div SizeOf(integer) - 1 ] of integer;
PIntegerArray = ^TIntegerArray;
PIntegerArrayDynArray = array of PIntegerArray;
TPIntegerArray = array[ 0 .. MaxInt div SizeOf(PIntegerArray) - 1 ] of PInteger;
PPIntegerArray = ^TPIntegerArray;
TCardinalArray = array[ 0 .. MaxInt div SizeOf(cardinal) - 1 ] of cardinal;
PCardinalArray = ^TCardinalArray;
TInt64Array = array[ 0 .. MaxInt div SizeOf(Int64) - 1 ] of Int64;
PInt64Array = ^TInt64Array;
TQWordArray = array[ 0 .. MaxInt div SizeOf(QWord) - 1 ] of QWord;
PQWordArray = ^TQWordArray;
TPtrUIntArray = array[ 0 .. MaxInt div SizeOf(PtrUInt) - 1 ] of PtrUInt;
PPtrUIntArray = ^TPtrUIntArray;
THalfUIntArray = array[ 0 .. MaxInt div SizeOf(HalfUInt) - 1 ] of HalfUInt;
PHalfUIntArray = ^THalfUIntArray;
TSmallIntArray = array[ 0 .. MaxInt div SizeOf(SmallInt) - 1 ] of SmallInt;
PSmallIntArray = ^TSmallIntArray;
TSingleArray = array[ 0 .. MaxInt div SizeOf(Single) - 1 ] of Single;
PSingleArray = ^TSingleArray;
TDoubleArray = array[ 0 .. MaxInt div SizeOf(Double) - 1 ] of Double;
PDoubleArray = ^TDoubleArray;
TDateTimeArray = array[ 0 .. MaxInt div SizeOf(TDateTime) - 1 ] of TDateTime;
PDateTimeArray = ^TDateTimeArray;
TPAnsiCharArray = array[ 0 .. MaxInt div SizeOf(PAnsiChar) - 1 ] of PAnsiChar;
PPAnsiCharArray = ^TPAnsiCharArray;
TRawUtf8Array = array[ 0 .. MaxInt div SizeOf(RawUtf8) - 1 ] of RawUtf8;
PRawUtf8Array = ^TRawUtf8Array;
TRawByteStringArray = array[ 0 .. MaxInt div SizeOf(RawByteString) - 1 ] of RawByteString;
PRawByteStringArray = ^TRawByteStringArray;
PShortStringArray = array[ 0 .. MaxInt div SizeOf(pointer) - 1 ] of PShortString;
TPointerArray = array[ 0 .. MaxInt div SizeOf(Pointer) - 1 ] of Pointer;
PPointerArray = ^TPointerArray;
TClassArray = array[ 0 .. MaxInt div SizeOf(TClass) - 1 ] of TClass;
PClassArray = ^TClassArray;
TObjectArray = array[ 0 .. MaxInt div SizeOf(TObject) - 1 ] of TObject;
PObjectArray = ^TObjectArray;
TPtrIntArray = array[ 0 .. MaxInt div SizeOf(PtrInt) - 1 ] of PtrInt;
PPtrIntArray = ^TPtrIntArray;
PInt64Rec = ^Int64Rec;
PLongRec = ^LongRec;
PPShortString = ^PShortString;
PTextFile = ^TextFile;
PInterface = ^IInterface;
TInterfaceDynArray = array of IInterface;
PInterfaceDynArray = ^TInterfaceDynArray;
TStreamClass = class of TStream;
TInterfacedObjectClass = class of TInterfacedObject;
TListClass = class of TList;
TObjectListClass = class of TObjectList;
TCollectionClass = class of TCollection;
TCollectionItemClass = class of TCollectionItem;
ExceptionClass = class of Exception;
{$M+}
ExceptionWithProps = class(Exception); // not as good as ESynException
{$M-}
type
/// used e.g. to serialize up to 256-bit as hexadecimal
TShort64 = string[64];
PShort64 = ^TShort64;
/// a shortstring which only takes 48 bytes of memory
TShort47 = string[47];
PShort47 = ^TShort47;
/// used e.g. for SetThreadName/GetCurrentThreadName
TShort31 = string[31];
PShort31 = ^TShort31;
/// used e.g. by PointerToHexShort/CardinalToHexShort/Int64ToHexShort/FormatShort16
// - such result type would avoid a string allocation on heap, so are highly
// recommended e.g. when logging small pieces of information
TShort16 = string[16];
PShort16 = ^TShort16;
/// used e.g. for TTextWriter.AddShorter small text constants
TShort8 = string[8];
PShort8 = ^TShort8;
/// stack-allocated ASCII string, used by GuidToShort() function
TGuidShortString = string[38];
/// cross-compiler type used for string length
// - FPC uses PtrInt/SizeInt, Delphi uses longint even on CPU64
TStrLen = {$ifdef FPC} SizeInt {$else} longint {$endif};
/// pointer to cross-compiler type used for string length
PStrLen = ^TStrLen;
/// cross-compiler type used for dynamic array length
// - both FPC and Delphi uses PtrInt/NativeInt for dynamic array high/length
TDALen = PtrInt;
/// pointer to cross-compiler type used for dynamic array length
PDALen = ^TDALen;
/// cross-compiler type used for string reference counter
// - FPC and Delphi don't always use the same type
TStrCnt = {$ifdef STRCNT32} integer {$else} SizeInt {$endif};
/// pointer to cross-compiler type used for string reference counter
PStrCnt = ^TStrCnt;
/// cross-compiler type used for dynarray reference counter
// - FPC uses PtrInt/SizeInt, Delphi uses longint even on CPU64
TDACnt = {$ifdef DACNT32} integer {$else} SizeInt {$endif};
/// pointer to cross-compiler type used for dynarray reference counter
PDACnt = ^TDACnt;
/// cross-compiler return type of IUnknown._AddRef/_Release methods
// - used to reduce the $ifdef when implementing interfaces in Delphi and FPC
TIntCnt = {$ifdef FPC} longint {$else} integer {$endif};
/// cross-compiler return type of IUnknown.QueryInterface method
// - used to reduce the $ifdef when implementing interfaces in Delphi and FPC
TIntQry = {$ifdef FPC} longint {$else} HRESULT {$endif};
{$ifdef FPC}
TStrRec = record // see TAnsiRec/TUnicodeRec in astrings/ustrings.inc
case integer of
0: (
{$ifdef HASCODEPAGE}
codePage: TSystemCodePage; // =Word
elemSize: Word;
{$ifndef STRCNT32}
{$ifdef CPU64}
_PaddingToQWord: DWord;
{$endif CPU64}
{$endif STRCNT32}
{$endif HASCODEPAGE}
refCnt: TStrCnt; // =SizeInt on older FPC, =longint since FPC 3.4
length: TStrLen;
);
{$ifdef HASCODEPAGE}
1: (
codePageElemSize: cardinal;
);
{$endif HASCODEPAGE}
end;
TDynArrayRec = record
refCnt: TDACnt; // =SizeInt
high: TDALen; // =SizeInt (differs from Delphi: equals length-1)
function GetLength: TDALen; inline;
procedure SetLength(len: TDALen); inline;
property length: TDALen // Delphi compatibility wrapper
read GetLength write SetLength;
end;
{$else not FPC}
/// map the Delphi/FPC string header (stored before each instance)
TStrRec = packed record
{$ifdef HASCODEPAGE}
{$ifdef CPU64}
/// padding bytes for 16 byte alignment of the header
_Padding: cardinal;
{$endif CPU64}
/// the string code page - e.g. CP_UTF8 for RawUtf8
codePage: Word;
/// 1 for AnsiString/RawByteString/RawUtf8, 2 for UnicodeString
elemSize: Word;
{$endif HASCODEPAGE}
/// string reference count (basic garbage memory mechanism)
refCnt: TStrCnt; // 32-bit longint with Delphi
/// equals length(s) - i.e. size in AnsiChar/WideChar, not bytes
length: TStrLen; // 32-bit longint with Delphi
end;
/// map the Delphi/FPC dynamic array header (stored before each instance)
TDynArrayRec = packed record
{$ifdef CPUX64}
/// padding bytes for 16 byte alignment of the header
_Padding: cardinal;
{$endif}
/// dynamic array reference count (basic garbage memory mechanism)
refCnt: TDACnt; // 32-bit longint with Delphi
/// length in element count
// - size in bytes = length*ElemSize
length: TDALen; // PtrInt/NativeInt
end;
{$endif FPC}
PStrRec = ^TStrRec;
PDynArrayRec = ^TDynArrayRec;
const
/// codePage offset = string header size
// - used to calc the beginning of memory allocation of a string
_STRRECSIZE = SizeOf(TStrRec);
/// cross-compiler negative offset to TStrRec.length field
// - to be used inlined e.g. as PStrLen(p - _STRLEN)^
_STRLEN = SizeOf(TStrLen);
/// cross-compiler negative offset to TStrRec.refCnt field
// - to be used inlined e.g. as PStrCnt(p - _STRCNT)^
_STRCNT = SizeOf(TStrCnt) + _STRLEN;
/// used to calc the beginning of memory allocation of a dynamic array
_DARECSIZE = SizeOf(TDynArrayRec);
/// cross-compiler negative offset to TDynArrayRec.high/length field
// - to be used inlined e.g. as
// ! PDALen(PAnsiChar(Values) - _DALEN)^ + _DAOFF
// - both FPC and Delphi uses PtrInt/NativeInt for dynamic array high/length
_DALEN = SizeOf(TDALen);
/// cross-compiler adjuster to get length from TDynArrayRec.high/length field
_DAOFF = {$ifdef FPC} 1 {$else} 0 {$endif};
/// cross-compiler negative offset to TDynArrayRec.refCnt field
// - to be used inlined e.g. as PDACnt(PAnsiChar(Values) - _DACNT)^
_DACNT = SizeOf(TDACnt) + _DALEN;
/// in-memory string process will allow up to 800 MB
// - used as high limit e.g. for TBufferWriter over a TRawByteStringStream
// - Delphi strings have a 32-bit length so you should change your algorithm
// - even if FPC on CPU64 can handle bigger strings, consider other patterns
_STRMAXSIZE = $5fffffff;
/// in-memory TBytes process will allow up to 800 MB
// - used as high limit e.g. for TBufferWriter.FlushToBytes
// - even if a dynamic array can handle PtrInt length, consider other patterns
_DAMAXSIZE = $5fffffff;
/// like SetLength() but without any memory resize - WARNING: len should be > 0
procedure DynArrayFakeLength(arr: pointer; len: TDALen);
{$ifdef HASINLINE} inline; {$endif}
{$ifndef CPUARM}
type
/// used as ToByte() to properly truncate any integer into 8-bit
// - is defined as an inlined "and 255" function under ARM to work as expected
ToByte = byte;
{$else}
function ToByte(value: cardinal): cardinal; inline;
{$endif CPUARM}
const
/// used to mark the end of ASCIIZ buffer, or return a void ShortString
NULCHAR: AnsiChar = #0;
/// a TGuid containing '{00000000-0000-0000-0000-00000000000}'
GUID_NULL: TGuid = ({%H-});
NULL_LOW = ord('n') + ord('u') shl 8 + ord('l') shl 16 + ord('l') shl 24;
FALSE_LOW = ord('f') + ord('a') shl 8 + ord('l') shl 16 + ord('s') shl 24;
FALSE_LOW2 = ord('a') + ord('l') shl 8 + ord('s') shl 16 + ord('e') shl 24;
TRUE_LOW = ord('t') + ord('r') shl 8 + ord('u') shl 16 + ord('e') shl 24;
/// fill a TGuid with 0
procedure FillZero(var result: TGuid); overload;
{$ifdef HASINLINE}inline;{$endif}
/// compare two TGuid values
// - this version is faster than the one supplied by SysUtils
function IsEqualGuid({$ifdef FPC_HAS_CONSTREF}constref{$else}const{$endif}
guid1, guid2: TGuid): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// compare two TGuid values
// - this version is faster than the one supplied by SysUtils
function IsEqualGuid(guid1, guid2: PGuid): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns the index of a matching TGuid in an array
// - returns -1 if no item matched
function IsEqualGuidArray(const guid: TGuid; const guids: array of TGuid): integer;
/// check if a TGuid value contains only 0 bytes
// - this version is faster than the one supplied by SysUtils
function IsNullGuid({$ifdef FPC_HAS_CONSTREF}constref{$else}const{$endif} guid: TGuid): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// append one TGuid item to a TGuid dynamic array
// - returning the newly inserted index in guids[], or an existing index in
// guids[] if NoDuplicates is TRUE and TGuid already exists
function AddGuid(var guids: TGuidDynArray; const guid: TGuid;
NoDuplicates: boolean = false): integer;
/// compute a random UUid value from the RandomBytes() generator and RFC 4122
procedure RandomGuid(out result: TGuid); overload;
/// compute a random UUid value from the RandomBytes() generator and RFC 4122
function RandomGuid: TGuid; overload;
{$ifdef HASINLINE}inline;{$endif}
/// compute the new capacity when expanding an array of items
// - handle tiny, small, medium, large and huge sizes properly to reduce
// memory usage and maximize performance
// - initial steps are 4, 8, 12, 28, 40, 56, 72, 88, 104, 120, 136, 170, 212,
// 265, 331, 413, 516, 645, 806, 1007, 1258, 1572, ...
function NextGrow(capacity: integer): integer;
/// equivalence to SetString(s,pansichar,len) function but from a raw pointer
// - so works with both PAnsiChar and PUtf8Char input buffer (or even PByteArray)
// - faster especially under FPC
procedure FastSetString(var s: RawUtf8; p: pointer; len: PtrInt); overload;
{$ifndef HASCODEPAGE} {$ifdef HASINLINE}inline;{$endif} {$endif}
/// faster equivalence to SetString(s,nil,len) function
procedure FastSetString(var s: RawUtf8; len: PtrInt); overload;
{$ifndef HASCODEPAGE} {$ifdef HASINLINE}inline;{$endif} {$endif}
/// equivalence to SetString(s,pansichar,len) function but from a raw pointer
// - so works with both PAnsiChar and PUtf8Char input buffer (or even PByteArray)
// - faster especially under FPC
procedure FastSetRawByteString(var s: RawByteString; p: pointer; len: PtrInt);
{$ifndef HASCODEPAGE} {$ifdef HASINLINE}inline;{$endif} {$endif}
/// equivalence to SetString(s,nil,len) function to allocate a new RawByteString
// - faster especially under FPC
procedure FastNewRawByteString(var s: RawByteString; len: PtrInt);
{$ifndef HASCODEPAGE} {$ifdef HASINLINE}inline;{$endif} {$endif}
/// equivalence to SetString(s,pansichar,len) function with a specific code page
// - faster especially under FPC
procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt);
{$ifndef HASCODEPAGE} {$ifdef HASINLINE}inline;{$endif} {$endif}
/// assign any constant or already ref-counted AnsiString/RawUtf8
// - by default, called with s = nil, is an equivalence to Finalize(d) or d := ''
// - is also called by FastSetString/FastSetStringCP to setup its allocated value
// - faster especially under FPC
procedure FastAssignNew(var d; s: pointer = nil);
{$ifndef FPC_CPUX64} {$ifdef HASINLINE}inline;{$endif} {$endif}
/// internal function to assign any constant or ref-counted AnsiString/RawUtf8
// - caller should have tested that pointer(d) <> nil
procedure FastAssignNewNotVoid(var d; s: pointer); overload;
{$ifndef FPC_CPUX64}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// internal function used by FastSetString/FastSetStringCP
function FastNewString(len, codepage: PtrInt): PAnsiChar;
{$ifdef HASINLINE}inline;{$endif}
/// ensure the supplied variable will have a CP_UTF8 - making it unique if needed
procedure EnsureRawUtf8(var s: RawByteString); overload;
{$ifdef HASINLINE}inline;{$endif}
/// ensure the supplied variable will have a CP_UTF8 - making it unique if needed
procedure EnsureRawUtf8(var s: RawUtf8); overload;
{$ifdef HASINLINE}inline;{$endif}
/// internal function which could be used instead of SetLength() if RefCnt = 1
procedure FakeLength(var s: RawUtf8; len: PtrInt); overload;
{$ifdef HASINLINE} inline; {$endif}
/// internal function which could be used instead of SetLength() if RefCnt = 1
procedure FakeLength(var s: RawUtf8; endChar: PUtf8Char); overload;
{$ifdef HASINLINE} inline; {$endif}
/// internal function which could be used instead of SetLength() if RefCnt = 1
procedure FakeLength(var s: RawByteString; len: PtrInt); overload;
{$ifdef HASINLINE} inline; {$endif}
/// internal function which could be used instead of SetLength() if RefCnt = 1
// - FakeLength() don't handle len = 0, whereas this function will
procedure FakeSetLength(var s: RawUtf8; len: PtrInt); overload;
/// internal function which could be used instead of SetLength() if RefCnt = 1
// - FakeLength() don't handle len = 0, whereas this function will
procedure FakeSetLength(var s: RawByteString; len: PtrInt); overload;
/// internal function which could be used instead of SetCodePage() if RefCnt = 1
// - do nothing if HASCODEPAGE is not defined, e.g. on Delphi 7-2007
// - warning: s should NOT be read-only (i.e. assigned from a constant), but
// a just-allocated string with RefCnt <> -1
procedure FakeCodePage(var s: RawByteString; cp: cardinal);
{$ifdef HASINLINE} inline; {$endif}
/// internal function which assign src to dest, force CP_UTF8 and set src to ''
// - warning: calls FakeCodePage(CP_UTF8) so requires src to have a RefCnt of 1
procedure FastAssignUtf8(var dest: RawUtf8; var src: RawByteString);
{$ifdef HASINLINE} inline; {$endif}
{$ifdef HASCODEPAGE}
/// retrieve the code page of a non void string
// - caller should have ensure that s <> ''
function GetCodePage(const s: RawByteString): cardinal; inline;
{$endif HASCODEPAGE}
/// initialize a RawByteString, ensuring returned "aligned" pointer
// is 16-bytes aligned
// - to be used e.g. for proper SIMD process
// - you can specify an alternate alignment, but it should be a power of two
procedure GetMemAligned(var holder: RawByteString; fillwith: pointer; len: PtrUInt;
out aligned: pointer; alignment: PtrUInt = 16);
/// equivalence to @u[1] expression to ensure a RawUtf8 variable is unique
// - will ensure that the string refcount is 1, and return a pointer to the text
// - under FPC, @u[1] does not call UniqueString() as it does with Delphi
// - if u is a constant (refcount=-1), will allocate a temporary copy in heap
function UniqueRawUtf8(var u: RawUtf8): pointer;
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of an ANSI-7 ShortString into an AnsiString
// - can be used e.g. for names retrieved from RTTI to convert them into RawUtf8
function ShortStringToAnsi7String(const source: ShortString): RawByteString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of an ANSI-7 ShortString into an AnsiString
// - can be used e.g. for names retrieved from RTTI to convert them into RawUtf8
procedure ShortStringToAnsi7String(const source: ShortString; var result: RawUtf8); overload;
{$ifdef HASINLINE}inline;{$endif}
/// direct conversion of an ANSI-7 AnsiString into an ShortString
// - can be used e.g. for names retrieved from RTTI
procedure Ansi7StringToShortString(const source: RawUtf8; var result: ShortString);
{$ifdef FPC}inline;{$endif}
/// simple concatenation of a 32-bit unsigned integer as text into a shorstring
procedure AppendShortCardinal(value: cardinal; var dest: ShortString);
/// simple concatenation of a 64-bit integer as text into a shorstring
procedure AppendShortInt64(value: Int64; var dest: ShortString);
/// simple concatenation of a character into a shorstring
procedure AppendShortChar(chr: AnsiChar; var dest: ShortString);
{$ifdef FPC} inline; {$endif}
/// simple concatenation of a byte as hexadecimal into a shorstring
procedure AppendShortByteHex(value: byte; var dest: ShortString);
/// simple concatenation of a ShortString text into a shorstring
procedure AppendShort(const src: ShortString; var dest: ShortString);
{$ifdef FPC} inline; {$endif}
/// simple concatenation of a #0 ending text into a shorstring
// - if Len is < 0, will use StrLen(buf)
procedure AppendShortBuffer(buf: PAnsiChar; len: integer; var dest: ShortString);
/// simple concatenation of an ANSI-7 AnsiString into a shorstring
// - if Len is < 0, will use StrLen(buf)
procedure AppendShortAnsi7String(const buf: RawByteString; var dest: ShortString);
{$ifdef FPC}inline;{$endif}
/// just a wrapper around vmtClassName to avoid a string conversion
function ClassNameShort(C: TClass): PShortString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// just a wrapper around vmtClassName to avoid a string conversion
function ClassNameShort(Instance: TObject): PShortString; overload;
{$ifdef HASINLINE}inline;{$endif}
/// just a wrapper around vmtClassName to avoid a string conversion
procedure ClassToText(C: TClass; var result: RawUtf8);
/// just a wrapper around ClassToText() to avoid a string conversion
function ToText(C: TClass): RawUtf8; overload;
{$ifdef HASSAFEINLINE}inline;{$endif}
var
/// retrieve the unit name where a given class is implemented
// - is implemented in mormot.core.rtti.pas; so may be nil otherwise
// - is needed since Delphi 7-2009 do not define TObject.UnitName (because
// there is no such information available in RTTI)
ClassUnit: function(C: TClass): PShortString;
/// just a wrapper around vmtParent to avoid a function call
// - slightly faster than TClass.ClassParent thanks to proper inlining
function GetClassParent(C: TClass): TClass;
{$ifdef HASINLINE}inline;{$endif}
/// case-insensitive comparison of two shortstrings only containing ASCII 7-bit
// - use e.g. with RTTI property names values only including A..Z,0..9,_ chars
// - will make the "XOR AND $DF" trick to quickly test A-Z / a-z characters
// - behavior is undefined with UTF-8 encoding (some false positive may occur)
// - see IdemPropName/IdemPropNameU functions in mormot.core.text for a similar
// comparison with other kind of input variables
function PropNameEquals(P1, P2: PShortString): boolean; overload;
{$ifdef FPC}inline;{$endif} // Delphi has troubles inlining goto/label
/// case-insensitive comparison of two RawUtf8 only containing ASCII 7-bit
// - use e.g. with RTTI property names values only including A..Z,0..9,_ chars
// - will make the "XOR AND $DF" trick to quickly test A-Z / a-z characters
// - behavior is undefined with UTF-8 encoding (some false positive may occur)
// - see IdemPropName/IdemPropNameU functions in mormot.core.text for a similar
// comparison with other kind of input variables
function PropNameEquals(const P1, P2: RawUtf8): boolean; overload;
/// raw internal method as published by FindNonVoid[false]
function FindNonVoidRawUtf8(n: PPointerArray; name: pointer; len: TStrLen;
count: PtrInt): PtrInt;
/// raw internal method as published by FindNonVoid[true]
function FindNonVoidRawUtf8I(n: PPointerArray; name: pointer; len: TStrLen;
count: PtrInt): PtrInt;
type
TFindNonVoid =
function(p: PPointerArray; n: pointer; l: TStrLen; c: PtrInt): PtrInt;
const
/// raw internal methods for case sensitive (or not) search for a RawUtf8
// - expects non-void RawUtf8 values, with ASCII-7 encoding, e.g. as with
// TDocVariantData.GetValueIndex() property names
FindNonVoid: array[{casesensitive:}boolean] of TFindNonVoid = (
FindNonVoidRawUtf8I,
FindNonVoidRawUtf8);
/// return the case-insensitive ASCII 7-bit index of Value in non-void Values[]
// - typical use with a TRawUtf8DynArray is like this:
// ! index := FindPropName(pointer(aDynArray), aValue, length(aDynArray));
// - by design, this function expects Values[] to not contain any void ''
function FindPropName(Values: PRawUtf8Array; const Value: RawUtf8;
ValuesCount: PtrInt): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// return the index of Value in Values[], -1 if not found
// - here name search would use fast IdemPropNameU() function
function FindPropName(const Names: array of RawUtf8; const Name: RawUtf8): integer; overload;
/// use the RTL to return a date/time as ISO-8601 text
// - slow function, here to avoid linking mormot.core.datetime
function DateTimeToIsoString(dt: TDateTime): string;
/// convert a binary into its human-friendly per-byte hexadecimal lowercase text
// - returns e.g. '12:50:b6:1e:c6:aa', i.e. the DN/MAC format
// - used e.g. in mormot.lib.openssl11 and mormot.net.sock
procedure ToHumanHex(var result: RawUtf8; bin: PByteArray; len: PtrInt);
/// convert a binary into its human-friendly hexadecimal in reverse order
procedure ToHumanHexReverse(var result: RawUtf8; bin: PByteArray; len: PtrInt);
// backward compatibility types redirections
{$ifndef PUREMORMOT2}
type
TSqlRawBlob = RawBlob;
{$endif PUREMORMOT2}
{ ************ Numbers (floats and integers) Low-level Definitions }
const
/// fast lookup table for converting any decimal number from
// 0 to 99 into their ASCII equivalence
TwoDigitLookup: packed array[0..99] of array[1..2] of AnsiChar =
('00', '01', '02', '03', '04', '05', '06', '07', '08', '09',
'10', '11', '12', '13', '14', '15', '16', '17', '18', '19',
'20', '21', '22', '23', '24', '25', '26', '27', '28', '29',
'30', '31', '32', '33', '34', '35', '36', '37', '38', '39',
'40', '41', '42', '43', '44', '45', '46', '47', '48', '49',
'50', '51', '52', '53', '54', '55', '56', '57', '58', '59',
'60', '61', '62', '63', '64', '65', '66', '67', '68', '69',
'70', '71', '72', '73', '74', '75', '76', '77', '78', '79',
'80', '81', '82', '83', '84', '85', '86', '87', '88', '89',
'90', '91', '92', '93', '94', '95', '96', '97', '98', '99');
var
/// fast lookup table for converting any decimal number from
// 0 to 99 into their ASCII equivalence
TwoDigitLookupW: packed array[0..99] of word absolute TwoDigitLookup;
/// best possible precision when rendering a "single" kind of float
// - can be used as parameter for ExtendedToShort/ExtendedToStr
// - is defined as a var, so that you may be able to override the default
// settings, for the whole process
SINGLE_PRECISION: integer = 8;
/// best possible precision when rendering a "double" kind of float
// - can be used as parameter for ExtendedToShort/ExtendedToStr
// - is defined as a var, so that you may be able to override the default
// settings, for the whole process
DOUBLE_PRECISION: integer = 15;
/// best possible precision when rendering a "extended" kind of float
// - can be used as parameter for ExtendedToShort/ExtendedToStr
// - is defined as a var, so that you may be able to override the default
// settings, for the whole process
EXTENDED_PRECISION: integer = 18;
type
/// small structure used as convenient result to Div100() procedure
TDiv100Rec = packed record
/// contains V div 100 after Div100(V)
D: cardinal;
/// contains V mod 100 after Div100(V)
M: cardinal;
end;
{$ifdef TSYNEXTENDED80}
/// the floating-point type to be used for best precision and speed
// - will allow to fallback to double e.g. on x64 and ARM CPUs
TSynExtended = extended;
TSynExtendedDynArray = array of TSynExtended;
PSynExtendedDynArray = ^TSynExtendedDynArray;
PSynExtended = ^TSynExtended;
{$else}
/// ARM/Delphi 64-bit does not support 80bit extended -> double is enough
TSynExtended = double;
TSynExtendedDynArray = TDoubleDynArray;
PSynExtendedDynArray = PDoubleDynArray;
PSynExtended = PDouble;
{$endif TSYNEXTENDED80}
/// the non-number values potentially stored in an IEEE floating point
TFloatNan = (
fnNumber, fnNan, fnInf, fnNegInf);
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
/// unaligned() will be defined and useful only on FPC ARM/Aarch64 plaforms
unaligned = Double;
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
const
/// used e.g. to convert a currency (via PInt64) into a double
// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
// values properly -> use FPC Win32 compiler only on Windows
CURR_RES = 10000;
/// convert a currency value into a double
// - using PInt64() division by CURR_RES (=10000)
// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
// values properly -> use FPC Win32 compiler only on Windows
procedure CurrencyToDouble(const c: currency; out d: double); overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a currency value pointer into a double
// - using PInt64() division by CURR_RES (=10000)
// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
// values properly -> use FPC Win32 compiler only on Windows
procedure CurrencyToDouble(c: PCurrency; out d: double); overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a currency value pointer into a double
// - using PInt64() division by CURR_RES (=10000)
// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
// values properly -> use FPC Win32 compiler only on Windows
function CurrencyToDouble(c: PCurrency): double; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fill a variant value from a currency value
// - as compatible with VariantToCurrency/VariantToDouble
// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
// values properly -> use FPC Win32 compiler only on Windows
procedure CurrencyToVariant(const c: currency; var v: variant);
{$ifdef HASINLINE}inline;{$endif}
/// convert a double value into a currency
// - using truncated multiplication by CURR_RES (=10000)
// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
// values properly -> use FPC Win32 compiler only on Windows
procedure DoubleToCurrency(const d: double; out c: currency); overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a double value into a currency
// - using truncated multiplication by CURR_RES (=10000)
// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
// values properly -> use FPC Win32 compiler only on Windows
procedure DoubleToCurrency(const d: double; c: PCurrency); overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a double value into a currency
// - using truncated multiplication by CURR_RES (=10000)
// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
// values properly -> use FPC Win32 compiler only on Windows
function DoubleToCurrency(const d: double): currency; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a currency value into a Int64
// - using PInt64() division by CURR_RES (=10000)
// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
// values properly -> use FPC Win32 compiler only on Windows
procedure CurrencyToInt64(c: PCurrency; var i: Int64); overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a Int64 value into a currency
// - using multiplication by CURR_RES (=10000)
// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
// values properly -> use FPC Win32 compiler only on Windows
procedure Int64ToCurrency(const i: Int64; out c: currency); overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a Int64 value into a currency
// - using multiplication by CURR_RES (=10000)
// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
// values properly -> use FPC Win32 compiler only on Windows
procedure Int64ToCurrency(const i: Int64; c: PCurrency); overload;
{$ifdef HASINLINE}inline;{$endif}
/// no banker rounding into two digits after the decimal point
// - #.##51 will round to #.##+0.01 and #.##50 will be truncated to #.##
// - implementation will use fast Int64 math to avoid any precision loss due to
// temporary floating-point conversion
function SimpleRoundTo2Digits(Value: Currency): Currency;
{$ifdef HASINLINE}inline;{$endif}
/// simple, no banker rounding of a Currency value, stored as Int64, to only 2 digits
// - #.##51 will round to #.##+0.01 and #.##50 will be truncated to #.##
// - implementation will use fast Int64 math to avoid any precision loss due to
// temporary floating-point conversion
procedure SimpleRoundTo2DigitsCurr64(var Value: Int64);
/// no banker rounding into text, with two digits after the decimal point
// - #.##51 will round to #.##+0.01 and #.##50 will be truncated to #.##
// - this function will only allow 2 digits in the returned text
function TwoDigits(const d: double): TShort31;
/// truncate a currency value to only 2 digits
// - implementation will use fast Int64 math to avoid any precision loss due to
// temporary floating-point conversion
function TruncTo2Digits(Value: currency): currency;
/// truncate a currency value, stored as Int64, to only 2 digits
// - implementation will use fast Int64 math to avoid any precision loss due to
// temporary floating-point conversion
procedure TruncTo2DigitsCurr64(var Value: Int64);
{$ifdef HASINLINE}inline;{$endif}
/// truncate a Currency value, stored as Int64, to only 2 digits
// - implementation will use fast Int64 math to avoid any precision loss due to
// temporary floating-point conversion
function TruncTo2Digits64(Value: Int64): Int64;
{$ifdef HASINLINE}inline;{$endif}
/// simple wrapper to efficiently compute both division and modulo per 100
// - compute result.D = Y div 100 and result.M = Y mod 100
// - under FPC, will use fast multiplication by reciprocal so can be inlined
// - under Delphi, we use our own optimized asm version (which can't be inlined)
procedure Div100(Y: cardinal; var res: TDiv100Rec);
{$ifdef FPC} inline; {$endif}
/// get the signed 32-bit integer value stored in P^
// - we use the PtrInt result type, even if expected to be 32-bit, to use
// native CPU register size (don't want any 32-bit overflow here)
// - will end parsing when P^ does not contain any number (e.g. it reaches any
// ending #0 char)
function GetInteger(P: PUtf8Char): PtrInt; overload;
/// get the signed 32-bit integer value stored in P^..PEnd^
// - will end parsing when P^ does not contain any number (e.g. it reaches any
// ending #0 char), or when P reached PEnd (avoiding any buffer overflow)
function GetInteger(P, PEnd: PUtf8Char): PtrInt; overload;
/// get the signed 32-bit integer value stored in P^
// - if P if nil or not start with a valid numerical value, returns Default
function GetIntegerDef(P: PUtf8Char; Default: PtrInt): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// get the signed 32-bit integer value stored in P^
// - this version return 0 in err if no error occurred, and 1 if an invalid
// character was found, not its exact index as for the val() function
function GetInteger(P: PUtf8Char; var err: integer): PtrInt; overload;
/// get the unsigned 32-bit integer value stored in P^
// - we use the PtrUInt result type, even if expected to be 32-bit, to use
// native CPU register size (don't want any 32-bit overflow here)
function GetCardinal(P: PUtf8Char): PtrUInt; overload;
/// get the unsigned 32-bit integer value stored in P^
// - we use the PtrUInt result type, even if expected to be 32-bit, to use
// native CPU register size (don't want any 32-bit overflow here)
function GetCardinal(P, PEnd: PUtf8Char): PtrUInt; overload;
/// get the unsigned 32-bit integer value stored in P^
// - if P if nil or not start with a valid numerical value, returns Default
function GetCardinalDef(P: PUtf8Char; Default: PtrUInt): PtrUInt;
/// get the unsigned 32-bit integer value stored as Unicode string in P^
function GetCardinalW(P: PWideChar): PtrUInt;
/// get a boolean value stored as 'true'/'false' text in P^
// - would also recognize any non '0' integer as true, or false if P = nil
// - see relaxed GetInt64Bool() to recognize e.g. 'TRUE' or 'yes'/'YES'
function GetBoolean(P: PUtf8Char): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// get a boolean value stored as 'true'/'false' text in input variable
// - would also recognize any non '0' integer as true, or false if P is ''
function GetBoolean(const value: RawUtf8): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// get the 64-bit integer value stored in P^
function GetInt64(P: PUtf8Char): Int64; overload;
{$ifdef HASINLINE}inline;{$endif}
/// get the 64-bit integer value stored in P^
// - if P if nil or not start with a valid numerical value, returns Default
function GetInt64Def(P: PUtf8Char; const Default: Int64): Int64;
/// return 1 if 'TRUE' or 'YES', or 0 otherwise
function GetTrue(P: PUtf8Char): integer;
{$ifdef HASINLINE}inline;{$endif}
/// get the 64-bit integer value from P^, recognizing true/false/yes/no input
// - return true on correct parsing, false if P is no number or boolean
function GetInt64Bool(P: PUtf8Char; out V: Int64): boolean;
/// get the 64-bit signed integer value stored in P^
procedure SetInt64(P: PUtf8Char; var result: Int64);
{$ifdef CPU64}inline;{$endif}
/// get the 64-bit unsigned integer value stored in P^
procedure SetQWord(P: PUtf8Char; var result: QWord); overload;
{$ifdef CPU64}inline;{$endif}
/// get the 64-bit unsigned integer value stored in P^
procedure SetQWord(P, PEnd: PUtf8Char; var result: QWord); overload;
{$ifdef CPU64}inline;{$endif}
/// get the 64-bit signed integer value stored in P^
// - set the err content to the index of any faulty character, 0 if conversion
// was successful (same as the standard val function)
function GetInt64(P: PUtf8Char; var err: integer): Int64; overload;
{$ifdef CPU64}inline;{$endif}
/// get the 64-bit unsigned integer value stored in P^
// - set the err content to the index of any faulty character, 0 if conversion
// was successful (same as the standard val function)
function GetQWord(P: PUtf8Char; var err: integer): QWord;
/// get the extended floating point value stored in P^
// - set the err content to the index of any faulty character, 0 if conversion
// was successful (same as the standard val function)
// - this optimized function is consistent on all platforms/compilers and return
// the decoded value even if err is not 0 (e.g. if P^ is not #0 ended)
function GetExtended(P: PUtf8Char; out err: integer): TSynExtended; overload;
/// get the extended floating point value stored in P^
// - this overloaded version returns 0 as a result if the content of P is invalid
function GetExtended(P: PUtf8Char): TSynExtended; overload;
{$ifdef HASINLINE}inline;{$endif}
type
TPow10 = array[-31..55] of TSynExtended;
PPow10 = ^TPow10;
const
/// most common 10 ^ exponent constants, ending with values for HugePower10*()
POW10: TPow10 = (
1E-31, 1E-30, 1E-29, 1E-28, 1E-27, 1E-26, 1E-25, 1E-24, 1E-23, 1E-22,
1E-21, 1E-20, 1E-19, 1E-18, 1E-17, 1E-16, 1E-15, 1E-14, 1E-13, 1E-12,
1E-11, 1E-10, 1E-9, 1E-8, 1E-7, 1E-6, 1E-5, 1E-4, 1E-3, 1E-2,
1E-1, 1E0, 1E1, 1E2, 1E3, 1E4, 1E5, 1E6, 1E7, 1E8,
1E9, 1E10, 1E11, 1E12, 1E13, 1E14, 1E15, 1E16, 1E17, 1E18,
1E19, 1E20, 1E21, 1E22, 1E23, 1E24, 1E25, 1E26, 1E27, 1E28,
1E29, 1E30, 1E31, 0,{32} -1,{33} 1E0,{34} 1E32, 1E64, 1E96, 1E128,
1E160, 1E192, 1E224, 1E256, 1E288, 1E320, 1E-0,{45} 1E-32, 1E-64,
1E-96, 1E-128, 1E-160, 1E-192, 1E-224, 1E-256, 1E-288, 1E-320);
/// low-level computation of 10 ^ positive exponent, if POW10[] is not enough
function HugePower10Pos(exponent: PtrInt; pow10: PPow10): TSynExtended;
{$ifdef HASINLINE}inline;{$endif}
/// low-level computation of 10 ^ negative exponent, if POW10[] is not enough
function HugePower10Neg(exponent: PtrInt; pow10: PPow10): TSynExtended;
{$ifdef HASINLINE}inline;{$endif}
/// get the signed 32-bit integer value stored in a RawUtf8 string
// - we use the PtrInt result type, even if expected to be 32-bit, to use
// native CPU register size (don't want any 32-bit overflow here)
function Utf8ToInteger(const value: RawUtf8; Default: PtrInt = 0): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// get the signed 64-bit integer value stored in a RawUtf8 string
// - returns the default value if the supplied text was not successfully
// converted into an Int64
function Utf8ToInt64(const text: RawUtf8; const default: Int64 = 0): Int64;
/// get and check range of a signed 32-bit integer stored in a RawUtf8 string
// - we use the PtrInt result type, even if expected to be 32-bit, to use
// native CPU register size (don't want any 32-bit overflow here)
function Utf8ToInteger(const value: RawUtf8; min, max: PtrInt;
default: PtrInt = 0): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// get the signed 32-bit integer value stored in a RawUtf8 string
// - returns TRUE if the supplied text was successfully converted into an integer
function ToInteger(const text: RawUtf8; out value: integer): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// get the unsigned 32-bit cardinal value stored in a RawUtf8 string
// - returns TRUE if the supplied text was successfully converted into a cardinal
function ToCardinal(const text: RawUtf8; out value: cardinal;
minimal: cardinal = 0): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// get the signed 64-bit integer value stored in a RawUtf8 string
// - returns TRUE if the supplied text was successfully converted into an Int64
function ToInt64(const text: RawUtf8; out value: Int64): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// get a 64-bit floating-point value stored in a RawUtf8 string
// - returns TRUE if the supplied text was successfully converted into a double
function ToDouble(const text: RawUtf8; out value: double): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// internal fast integer val to text conversion
// - expect the last available temporary char position in P
// - return the last written char position (write in reverse order in P^)
// - typical use:
// !function Int32ToUtf8(Value: PtrInt): RawUtf8;
// !var
// ! tmp: array[0..23] of AnsiChar;
// ! P: PAnsiChar;
// !begin
// ! P := StrInt32(@tmp[23],Value);
// ! SetString(result,P,@tmp[23]-P);
// !end;
// - convert the input value as PtrInt, so as Int64 on 64-bit CPUs
// - not to be called directly: use IntToStr() or Int32ToUtf8() instead
function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar;
/// internal fast unsigned integer val to text conversion
// - expect the last available temporary char position in P
// - return the last written char position (write in reverse order in P^)
// - convert the input value as PtrUInt, so as QWord on 64-bit CPUs
function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar;
/// internal fast Int64 val to text conversion
// - same calling convention as with StrInt32() above
function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar;
{$ifdef HASINLINE}inline;{$endif}
/// internal fast unsigned Int64 val to text conversion
// - same calling convention as with StrInt32() above
function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar;
{$ifdef CPU64}inline;{$endif}
/// add the 4 digits of integer Y to P^ as '0000'..'9999'
procedure YearToPChar(Y: PtrUInt; P: PUtf8Char);
{$ifndef ASMX86} {$ifdef HASINLINE}inline;{$endif} {$endif}
const
/// a typical error allowed when working with double floating-point values
// - 1E-12 is too small, and triggers sometimes some unexpected errors;
// FPC RTL uses 1E-4 so we are paranoid enough
DOUBLE_SAME = 1E-11;
/// compare to floating point values, with IEEE 754 double precision
// - use this function instead of raw = operator
// - the precision is calculated from the A and B value range
// - faster equivalent than SameValue() in Math unit
// - if you know the precision range of A and B, it's faster to check abs(A-B)<range
function SameValue(const A, B: Double; DoublePrec: double = DOUBLE_SAME): boolean;
/// compare to floating point values, with IEEE 754 double precision
// - use this function instead of raw = operator
// - the precision is calculated from the A and B value range
// - faster equivalent than SameValue() in Math unit
// - if you know the precision range of A and B, it's faster to check abs(A-B)<range
function SameValueFloat(const A, B: TSynExtended;
DoublePrec: TSynExtended = DOUBLE_SAME): boolean;
/// a comparison function for sorting IEEE 754 double precision values
function CompareFloat(const A, B: double): integer;
{$ifdef HASINLINE}inline;{$endif}
/// compute the sum of values, using a running compensation for lost low-order bits
// - a naive "Sum := Sum + Data" will be restricted to 53 bits of resolution,
// so will eventually result in an incorrect number
// - Kahan algorithm keeps track of the accumulated error in integer operations,
// to achieve a precision of more than 100 bits
// - see https://en.wikipedia.org/wiki/Kahan_summation_algorithm
procedure KahanSum(const Data: double; var Sum, Carry: double);
{$ifdef HASINLINE}inline;{$endif}
{ ************ integer Arrays Manipulation }
/// returns TRUE if Value is nil or all supplied Values[] equal 0
function IsZero(const Values: TIntegerDynArray): boolean; overload;
/// returns TRUE if Value is nil or all supplied Values[] equal 0
function IsZero(const Values: TInt64DynArray): boolean; overload;
/// fill all entries of a supplied array of 32-bit integers with 0
procedure FillZero(var Values: TIntegerDynArray); overload;
/// fill all entries of a supplied array of 64-bit integers with 0
procedure FillZero(var Values: TInt64DynArray); overload;
/// a comparison function for sorting 32-bit signed integer values
function CompareInteger(const A, B: integer): integer;
{$ifdef HASINLINE}inline;{$endif}
/// a comparison function for sorting 32-bit unsigned integer values
function CompareCardinal(const A, B: cardinal): integer;
{$ifdef HASINLINE}inline;{$endif}
/// a comparison function for sorting 64-bit signed integer values
function CompareInt64(const A, B: Int64): integer;
{$ifdef HASINLINE}inline;{$endif}
/// a comparison function for sorting 32/64-bit signed integer values
function ComparePtrInt(const A, B: PtrInt): integer;
{$ifdef HASINLINE}inline;{$endif}
/// a comparison function for sorting 32/64-bit pointers as unsigned values
function ComparePointer(const A, B: pointer): integer;
{$ifdef HASINLINE}inline;{$endif}
/// a comparison function for sorting 64-bit unsigned integer values
// - note that QWord(A)>QWord(B) is wrong on older versions of Delphi, so you
// should better use this function or SortDynArrayQWord() to properly compare
// two QWord values over CPUX86 on Delphi 7-2007
function CompareQWord(const A, B: QWord): integer;
{$ifdef HASINLINE}inline;{$endif}
/// fast search of an unsigned integer item in a 32-bit integer array
// - Count is the number of cardinal entries in P^
// - returns P where P^=Value
// - returns nil if Value was not found
// - is implemented via IntegerScanIndex() SSE2 asm on i386 and x86_64
function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal;
{$ifdef CPUINTEL} {$ifndef HASNOSSE2} {$ifdef HASINLINE}inline;{$endif} {$endif} {$endif}
/// fast search of an unsigned integer position in a 32-bit integer array
// - Count is the number of integer entries in P^
// - return index of P^[index]=Value
// - return -1 if Value was not found
// - is implemented with SSE2 asm on i386 and x86_64
function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt;
{$ifndef CPUINTEL}inline;{$endif}
/// fast search of an unsigned integer in a 32-bit integer array
// - returns true if P^=Value within Count entries
// - returns false if Value was not found
// - is implemented via IntegerScanIndex() SSE2 asm on i386 and x86_64
function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean;
{$ifdef CPUINTEL} {$ifndef HASNOSSE2} {$ifdef HASINLINE}inline;{$endif} {$endif} {$endif}
/// fast search of an integer position in a 64-bit integer array
// - Count is the number of Int64 entries in P^
// - returns P where P^=Value
// - returns nil if Value was not found
function Int64Scan(P: PInt64Array; Count: PtrInt; const Value: Int64): PInt64;
/// fast search of an integer position in a signed 64-bit integer array
// - Count is the number of Int64 entries in P^
// - returns index of P^[index]=Value
// - returns -1 if Value was not found
function Int64ScanIndex(P: PInt64Array; Count: PtrInt; const Value: Int64): PtrInt;
{$ifdef HASSAFEINLINE}inline;{$endif}
/// fast search of an integer position in an unsigned 64-bit integer array
// - Count is the number of QWord entries in P^
// - returns index of P^[index]=Value
// - returns -1 if Value was not found
function QWordScanIndex(P: PQWordArray; Count: PtrInt; const Value: QWord): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// fast search of an integer value in a 64-bit integer array
// - returns true if P^=Value within Count entries
// - returns false if Value was not found
function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean;
/// fast search of a pointer-sized unsigned integer position
// in an pointer-sized integer array
// - Count is the number of pointer-sized integer entries in P^
// - return index of P^[index]=Value
// - return -1 if Value was not found
function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// fast search of a pointer-sized unsigned integer in an pointer-sized integer array
// - Count is the number of pointer-sized integer entries in P^
// - returns true if P^=Value within Count entries
// - returns false if Value was not found
function PtrUIntScan(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): pointer;
{$ifdef HASINLINE}inline;{$endif}
/// fast search of a pointer-sized unsigned integer position
// in an pointer-sized integer array
// - Count is the number of pointer-sized integer entries in P^
// - returns true if P^=Value within Count entries
// - returns false if Value was not found
function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// fast search of an unsigned byte value position in a byte array
// - Count is the number of byte entries in P^
// - return index of P^[index]=Value, -1 if Value was not found
// - is implemented with SSE2 asm on i386 and x86_64
function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: byte): PtrInt;
{$ifndef CPUINTEL} inline; {$endif}
/// fast search of an unsigned Word value position in a Word array
// - Count is the number of Word entries in P^
// - return index of P^[index]=Value, -1 if Value was not found
// - is implemented with SSE2 asm on i386 and x86_64
function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt;
{$ifndef CPUINTEL} inline; {$endif}
/// sort an integer array, low values first
procedure QuickSortInteger(ID: PIntegerArray; L, R: PtrInt); overload;
/// sort an integer array, low values first
procedure QuickSortInteger(ID, CoValues: PIntegerArray; L, R: PtrInt); overload;
/// sort an integer array, low values first
procedure QuickSortInteger(var ID: TIntegerDynArray); overload;
/// sort a 16-bit unsigned integer array, low values first
procedure QuickSortWord(ID: PWordArray; L, R: PtrInt);
/// sort a 64-bit signed integer array, low values first
procedure QuickSortInt64(ID: PInt64Array; L, R: PtrInt); overload;
/// sort a 64-bit unsigned integer array, low values first
// - QWord comparison are implemented correctly under FPC or Delphi 2009+ -
// older compilers will use fast and exact SortDynArrayQWord()
procedure QuickSortQWord(ID: PQWordArray; L, R: PtrInt); overload;
/// sort a 64-bit integer array, low values first
procedure QuickSortInt64(ID, CoValues: PInt64Array; L, R: PtrInt); overload;
/// sort a PtrInt array, low values first
procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// sort a pointer array, low values first
procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// sort a double array, low values first
procedure QuickSortDouble(ID: PDoubleArray; L, R: PtrInt);
/// fast O(log(n)) binary search of an integer value in a sorted integer array
// - R is the last index of available integer entries in P^ (i.e. Count-1)
// - return index of P^[result]=Value
// - return -1 if Value was not found
// - use branchless asm on x86_64
function FastFindIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt; overload;
/// fast O(log(n)) binary search of an integer value in a sorted integer array
// - return index of Values[result]=Value
// - return -1 if Value was not found
function FastFindIntegerSorted(const Values: TIntegerDynArray; Value: integer): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast O(log(n)) binary search of a 16-bit unsigned integer value in a sorted array
// - use branchless asm on x86_64
function FastFindWordSorted(P: PWordArray; R: PtrInt; Value: Word): PtrInt;
/// fast O(log(n)) binary search of a 64-bit signed integer value in a sorted array
// - R is the last index of available integer entries in P^ (i.e. Count-1)
// - return index of P^[result]=Value
// - return -1 if Value was not found
// - use branchless asm on x86_64
function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt; overload;
/// fast O(log(n)) binary search of a 64-bit unsigned integer value in a sorted array
// - R is the last index of available integer entries in P^ (i.e. Count-1)
// - return index of P^[result]=Value
// - return -1 if Value was not found
// - QWord comparison are implemented correctly under FPC or Delphi 2009+ -
// older compilers will fast and exact SortDynArrayQWord()
function FastFindQWordSorted(P: PQWordArray; R: PtrInt; const Value: QWord): PtrInt; overload;
/// fast O(log(n)) binary search of a PtrInt value in a sorted array
function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast O(log(n)) binary search of a Pointer value in a sorted array
function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: Pointer): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// retrieve the index where to insert an integer value in a sorted integer array
// - R is the last index of available integer entries in P^ (i.e. Count-1)
// - returns -(foundindex+1) i.e. <0 if the specified Value was found
function FastLocateIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt;
/// retrieve the matching index or where to insert an integer value
function FastSearchIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt;
/// retrieve the index where to insert a word value in a sorted word array
// - R is the last index of available integer entries in P^ (i.e. Count-1)
// - returns -(foundindex+1) i.e. <0 if the specified Value was found
function FastLocateWordSorted(P: PWordArray; R: integer; Value: word): PtrInt;
/// add an integer value in a sorted dynamic array of integers
// - returns the index where the Value was added successfully in Values[]
// - returns -(foundindex+1) i.e. <0 if the specified Value was already present
// - if CoValues is set, its content will be moved to allow inserting a new
// value at CoValues[result] position
function AddSortedInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Value: integer; CoValues: PIntegerDynArray = nil): PtrInt; overload;
/// add an integer value in a sorted dynamic array of integers
// - overloaded function which do not expect an external Count variable
function AddSortedInteger(var Values: TIntegerDynArray;
Value: integer; CoValues: PIntegerDynArray = nil): PtrInt; overload;
/// insert an integer value at the specified index position of a dynamic array
// of integers
// - if Index is invalid, the Value is inserted at the end of the array
function InsertInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Value: integer; Index: PtrInt; CoValues: PIntegerDynArray = nil): PtrInt;
/// add an integer value at the end of a dynamic array of integers
// - returns TRUE if Value was added successfully in Values[], in this case
// length(Values) will be increased
function AddInteger(var Values: TIntegerDynArray; Value: integer;
NoDuplicates: boolean = false): boolean; overload;
/// add an integer value at the end of a dynamic array of integers
// - this overloaded function will use a separate Count variable (faster)
// - it won't search for any existing duplicate
procedure AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Value: integer); overload;
{$ifdef HASINLINE}inline;{$endif}
/// add an integer array at the end of a dynamic array of integer
function AddInteger(var Values: TIntegerDynArray;
const Another: TIntegerDynArray): PtrInt; overload;
/// add an integer value at the end of a dynamic array of integers
// - this overloaded function will use a separate Count variable (faster),
// and would allow to search for duplicates
// - returns TRUE if Value was added successfully in Values[], in this case
// ValuesCount will be increased, but length(Values) would stay fixed most
// of the time (since it stores the Values[] array capacity)
function AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Value: integer; NoDuplicates: boolean): boolean; overload;
/// add a 16-bit integer value at the end of a dynamic array of integers
function AddWord(var Values: TWordDynArray; var ValuesCount: integer;
Value: Word): PtrInt;
/// add a 64-bit integer value at the end of a dynamic array of integers
function AddInt64(var Values: TInt64DynArray; var ValuesCount: integer;
Value: Int64): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// add a 64-bit integer value at the end of a dynamic array
function AddInt64(var Values: TInt64DynArray; Value: Int64): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// add a 64-bit integer array at the end of a dynamic array
function AddInt64(var Values: TInt64DynArray;
const Another: TInt64DynArray): PtrInt; overload;
/// if not already existing, add a 64-bit integer value to a dynamic array
function AddInt64Once(var Values: TInt64DynArray; Value: Int64): PtrInt;
/// if not already existing, add a 64-bit integer value to a sorted dynamic array
procedure AddInt64Sorted(var Values: TInt64DynArray; Value: Int64);
/// add a pointer-sized integer array at the end of a dynamic array
function AddPtrUInt(var Values: TPtrUIntDynArray;
var ValuesCount: integer; Value: PtrUInt): PtrInt;
/// delete any 32-bit integer in Values[]
procedure DeleteInteger(var Values: TIntegerDynArray; Index: PtrInt); overload;
/// delete any 32-bit integer in Values[]
procedure DeleteInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Index: PtrInt); overload;
/// delete any 16-bit integer in Values[]
procedure DeleteWord(var Values: TWordDynArray; Index: PtrInt);
/// delete any 64-bit integer in Values[]
procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt); overload;
/// delete any 64-bit integer in Values[]
procedure DeleteInt64(var Values: TInt64DynArray; var ValuesCount: integer;
Index: PtrInt); overload;
/// fill some values with i,i+1,i+2...i+Count-1
procedure FillIncreasing(Values: PIntegerArray; StartValue: integer; Count: PtrUInt);
/// quick helper to initialize a dynamic array of integer from some constants
// - can be used e.g. as:
// ! MyArray := TIntegerDynArrayFrom([1,2,3]);
// - see also FromI32()
function TIntegerDynArrayFrom(const Values: array of integer): TIntegerDynArray;
/// quick helper to initialize a dynamic array of integer from 64-bit integers
// - will raise an Exception if any Value[] can not fit into 32-bit, unless
// raiseExceptionOnOverflow is FALSE and the returned array slot is filled
// with maxInt/minInt
function TIntegerDynArrayFrom64(const Values: TInt64DynArray;
raiseExceptionOnOverflow: boolean = true): TIntegerDynArray;
/// quick helper to initialize a dynamic array of 64-bit integers from 32-bit values
// - see also FromI64() for 64-bit signed integer values input
function TInt64DynArrayFrom(const Values: TIntegerDynArray): TInt64DynArray;
/// quick helper to initialize a dynamic array of 64-bit integers from 32-bit values
// - see also FromU64() for 64-bit unsigned integer values input
function TQWordDynArrayFrom(const Values: TCardinalDynArray): TQWordDynArray;
/// initializes a dynamic array from a set of 32-bit integer signed values
function FromI32(const Values: array of integer): TIntegerDynArray;
{$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// initializes a dynamic array from a set of 32-bit integer unsigned values
function FromU32(const Values: array of cardinal): TCardinalDynArray;
{$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// initializes a dynamic array from a set of 64-bit integer signed values
function FromI64(const Values: array of Int64): TInt64DynArray;
{$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// initializes a dynamic array from a set of 64-bit integer unsigned values
function FromU64(const Values: array of QWord): TQWordDynArray;
{$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif}
type
/// used to store and retrieve Words in a sorted array
// - ensure Count=0 before use - if not defined as a private member of a class
{$ifdef USERECORDWITHMETHODS}
TSortedWordArray = record
{$else}
TSortedWordArray = object
{$endif USERECORDWITHMETHODS}
public
/// the actual 16-bit word storage
Values: TWordDynArray;
/// how many items are currently in Values[]
Count: PtrInt;
/// add a value into the sorted array
// - return the index of the new inserted value into the Values[] array
// - return -(foundindex+1) if this value is already in the Values[] array
function Add(aValue: Word): PtrInt;
/// return the index if the supplied value in the Values[] array
// - return -1 if not found
function IndexOf(aValue: Word): PtrInt; {$ifdef HASINLINE}inline;{$endif}
/// save the internal array into a TWordDynArray variable
procedure SetArray(out aValues: TWordDynArray);
end;
PSortedWordArray = ^TSortedWordArray;
/// used to store and retrieve Integers in a sorted array
// - ensure Count=0 before use - if not defined as a private member of a class
{$ifdef USERECORDWITHMETHODS}
TSortedIntegerArray = record
{$else}
TSortedIntegerArray = object
{$endif USERECORDWITHMETHODS}
public
/// the actual 32-bit integers storage
Values: TIntegerDynArray;
/// how many items are currently in Values[]
Count: PtrInt;
/// add a value into the sorted array
// - return the index of the new inserted value into the Values[] array
// - return -(foundindex+1) if this value is already in the Values[] array
function Add(aValue: integer): PtrInt;
/// return the index if the supplied value in the Values[] array
// - return -1 if not found
function IndexOf(aValue: integer): PtrInt; {$ifdef HASINLINE}inline;{$endif}
/// save the internal array into a TWordDynArray variable
procedure SetArray(out aValues: TIntegerDynArray);
end;
PSortedIntegerArray = ^TSortedIntegerArray;
/// compute GCD of two integers using modulo-based Euclidean algorithm
function gcd(a, b: PtrUInt): PtrUInt;
{ ************ ObjArray PtrArray InterfaceArray Wrapper Functions }
/// wrapper to add an item to a array of pointer dynamic array storage
function PtrArrayAdd(var aPtrArray; aItem: pointer): integer; overload;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to add an item to a array of pointer dynamic array storage
function PtrArrayAdd(var aPtrArray; aItem: pointer;
var aPtrArrayCount: integer): PtrInt; overload;
/// wrapper to add once an item to a array of pointer dynamic array storage
function PtrArrayAddOnce(var aPtrArray; aItem: pointer): PtrInt; overload;
/// wrapper to add once an item to a array of pointer dynamic array storage
function PtrArrayAddOnce(var aPtrArray; aItem: pointer;
var aPtrArrayCount: integer): PtrInt; overload;
/// wrapper to insert an item to a array of pointer dynamic array storage
function PtrArrayInsert(var aPtrArray; aItem: pointer; aIndex: PtrInt;
var aPtrArrayCount: integer): PtrInt; overload;
/// wrapper to delete an item from a array of pointer dynamic array storage
function PtrArrayDelete(var aPtrArray; aItem: pointer; aCount: PInteger = nil): PtrInt; overload;
/// wrapper to delete an item from a array of pointer dynamic array storage
procedure PtrArrayDelete(var aPtrArray; aIndex: PtrInt; aCount: PInteger = nil); overload;
/// wrapper to find an item to a array of pointer dynamic array storage
function PtrArrayFind(var aPtrArray; aItem: pointer): integer;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to add an item to a T*ObjArray dynamic array storage
// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
// - could be used as such (note the T*ObjArray type naming convention):
// ! TUserObjArray = array of TUser;
// ! ...
// ! var arr: TUserObjArray;
// ! user: TUser;
// ! ..
// ! try
// ! user := TUser.Create;
// ! user.Name := 'Name';
// ! index := ObjArrayAdd(arr,user);
// ! ...
// ! finally
// ! ObjArrayClear(arr); // release all items
// ! end;
// - return the index of the item in the dynamic array
function ObjArrayAdd(var aObjArray; aItem: TObject): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to add an item to a T*ObjArray dynamic array storage
// - this overloaded function will use a separated variable to store the items
// count, so will be slightly faster: but you should call SetLength() when done,
// to have a stand-alone array as expected by our ORM/SOA serialziation
// - return the index of the item in the dynamic array
function ObjArrayAddCount(var aObjArray; aItem: TObject;
var aObjArrayCount: integer): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to add items to a T*ObjArray dynamic array storage
// - aSourceObjArray[] items are just copied to aDestObjArray, which remains untouched
// - return the new number of the items in aDestObjArray
function ObjArrayAddFrom(var aDestObjArray; const aSourceObjArray): PtrInt;
/// wrapper to add and move items to a T*ObjArray dynamic array storage
// - aSourceObjArray[] items will be owned by aDestObjArray[], therefore
// aSourceObjArray is set to nil
// - return the new number of the items in aDestObjArray
function ObjArrayAppend(var aDestObjArray, aSourceObjArray): PtrInt;
/// wrapper to add once an item to a T*ObjArray dynamic array storage
// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
// - if the object is already in the array (searching by address/reference,
// not by content), return its current index in the dynamic array
// - if the object does not appear in the array, add it at the end
function ObjArrayAddOnce(var aObjArray; aItem: TObject): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to add once an item to a T*ObjArray dynamic array storage and Count
function ObjArrayAddOnce(var aObjArray; aItem: TObject;
var aObjArrayCount: integer): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
// - aSourceObjArray[] items are just copied to aDestObjArray, which remains untouched
// - will first check if aSourceObjArray[] items are not already in aDestObjArray
// - return the new number of the items in aDestObjArray
function ObjArrayAddOnceFrom(var aDestObjArray; const aSourceObjArray): PtrInt;
/// wrapper to set the length of a T*ObjArray dynamic array storage
// - could be used as an alternative to SetLength() when you do not
// know the exact T*ObjArray type
procedure ObjArraySetLength(var aObjArray; aLength: integer);
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to search an item in a T*ObjArray dynamic array storage
// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
// - search is performed by address/reference, not by content
// - returns -1 if the item is not found in the dynamic array
function ObjArrayFind(const aObjArray; aItem: TObject): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to search an item in a T*ObjArray dynamic array storage
// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
// - search is performed by address/reference, not by content
// - returns -1 if the item is not found in the dynamic array
function ObjArrayFind(const aObjArray; aCount: integer; aItem: TObject): PtrInt; overload;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to count all not nil items in a T*ObjArray dynamic array storage
// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
function ObjArrayNotNilCount(const aObjArray): integer;
/// wrapper to delete an item in a T*ObjArray dynamic array storage
// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
// - do nothing if the index is out of range in the dynamic array
procedure ObjArrayDelete(var aObjArray; aItemIndex: PtrInt;
aContinueOnException: boolean = false; aCount: PInteger = nil); overload;
/// wrapper to delete an item in a T*ObjArray dynamic array storage
// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
// - search is performed by address/reference, not by content
// - do nothing if the item is not found in the dynamic array
function ObjArrayDelete(var aObjArray; aItem: TObject): PtrInt; overload;
/// wrapper to delete an item in a T*ObjArray dynamic array storage
// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
// - search is performed by address/reference, not by content
// - do nothing if the item is not found in the dynamic array
function ObjArrayDelete(var aObjArray; aCount: integer; aItem: TObject): PtrInt; overload;
/// wrapper to release all items stored in a T*ObjArray dynamic array
// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
// - you should always use ObjArrayClear() before the array storage is released,
// e.g. in the owner class destructor
// - when T*ObjArray are used as SOA parameters, no need to release the values
// - will also set the dynamic array length to 0, so could be used to re-use
// an existing T*ObjArray
procedure ObjArrayClear(var aObjArray); overload;
/// wrapper to release all items stored in a T*ObjArray dynamic array
// - this overloaded function will use the supplied array length as parameter
// - you should always use ObjArrayClear() before the array storage is released,
// e.g. in the owner class destructor
// - will also set the dynamic array length to 0, so could be used to re-use
// an existing T*ObjArray
procedure ObjArrayClear(var aObjArray; aCount: integer); overload;
/// wrapper to release all items stored in a T*ObjArray dynamic array
// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
// - you should always use ObjArrayClear() before the array storage is released,
// e.g. in the owner class destructor
// - will also set the dynamic array length to 0, so could be used to re-use
// an existing T*ObjArray
procedure ObjArrayClear(var aObjArray; aContinueOnException: boolean;
aCount: PInteger = nil); overload;
/// wrapper to release all items stored in an array of T*ObjArray dynamic array
// - e.g. aObjArray may be defined as "array of array of TSynFilter"
procedure ObjArrayObjArrayClear(var aObjArray);
/// wrapper to release all items stored in several T*ObjArray dynamic arrays
// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
procedure ObjArraysClear(const aObjArray: array of pointer);
/// low-level function calling FreeAndNil(o^) successively n times
procedure RawObjectsClear(o: PObject; n: integer);
/// same as FreeAndNil() but catching and ignoring any exception
// - only difference is that aObj is set to nil AFTER being destroyed
procedure FreeAndNilSafe(var aObj);
/// same as aInterface := nil but ignoring any exception
procedure InterfaceNilSafe(var aInterface);
/// same as aInterface := nil but ignoring any exception
procedure InterfacesNilSafe(const aInterfaces: array of pointer);
/// wrapper to add an item to a T*InterfaceArray dynamic array storage
function InterfaceArrayAdd(var aInterfaceArray; const aItem: IUnknown): PtrInt;
/// wrapper to add an item to a T*InterfaceArray dynamic array storage
function InterfaceArrayAddCount(var aInterfaceArray; var aCount: integer;
const aItem: IUnknown): PtrInt;
/// wrapper to add once an item to a T*InterfaceArray dynamic array storage
procedure InterfaceArrayAddOnce(var aInterfaceArray; const aItem: IUnknown);
/// wrapper to search an item in a T*InterfaceArray dynamic array storage
// - search is performed by address/reference, not by content
// - return -1 if the item is not found in the dynamic array, or the index of
// the matching entry otherwise
function InterfaceArrayFind(const aInterfaceArray; const aItem: IUnknown): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// wrapper to delete an item in a T*InterfaceArray dynamic array storage
// - search is performed by address/reference, not by content
// - do nothing if the item is not found in the dynamic array
function InterfaceArrayDelete(var aInterfaceArray; const aItem: IUnknown): PtrInt; overload;
/// wrapper to delete an item in a T*InterfaceArray dynamic array storage
// - do nothing if the item is not found in the dynamic array
procedure InterfaceArrayDelete(var aInterfaceArray; aItemIndex: PtrInt); overload;
{ ************ Low-level Types Mapping Binary Structures }
type
/// binary access to an unsigned 32-bit value (4 bytes in memory)
TDWordRec = record
case integer of
0: (
V: DWord);
1: (
L, H: word);
2: (
B: array[0..3] of byte);
end;
/// points to the binary of an unsigned 32-bit value
PDWordRec = ^TDWordRec;
/// binary access to an unsigned 64-bit value (8 bytes in memory)
TQWordRec = record
case integer of
0: (
V: Qword);
1: (
L, H: cardinal);
2: (
Li, Hi: integer);
3: (
W: array[0..3] of word);
4: (
B: array[0..7] of byte);
end;
/// points to the binary of an unsigned 64-bit value
PQWordRec = ^TQWordRec;
/// store a 128-bit hash value
// - e.g. a MD5 digest, or array[0..3] of cardinal (TBlock128)
// - consumes 16 bytes of memory
THash128 = array[0..15] of byte;
/// pointer to a 128-bit hash value
PHash128 = ^THash128;
/// store a 160-bit hash value
// - e.g. a SHA-1 digest
// - consumes 20 bytes of memory
THash160 = array[0..19] of byte;
/// pointer to a 160-bit hash value
PHash160 = ^THash160;
/// store a 192-bit hash value
// - consumes 24 bytes of memory
THash192 = array[0..23] of byte;
/// pointer to a 192-bit hash value
PHash192 = ^THash192;
/// store a 224-bit hash value
// - consumes 28 bytes of memory
THash224 = array[0..27] of byte;
/// pointer to a 224-bit hash value
PHash224 = ^THash224;
/// store a 256-bit hash value
// - e.g. a SHA-256 digest, a TEccSignature result, or array[0..7] of cardinal
// - consumes 32 bytes of memory
THash256 = array[0..31] of byte;
/// pointer to a 256-bit hash value
PHash256 = ^THash256;
/// store a 384-bit hash value
// - e.g. a SHA-384 digest
// - consumes 48 bytes of memory
THash384 = array[0..47] of byte;
/// pointer to a 384-bit hash value
PHash384 = ^THash384;
/// store a 512-bit hash value
// - e.g. a SHA-512 digest, a TEccSignature result, or array[0..15] of cardinal
// - consumes 64 bytes of memory
THash512 = array[0..63] of byte;
/// pointer to a 512-bit hash value
PHash512 = ^THash512;
/// store a 128-bit buffer
// - e.g. an AES block
// - consumes 16 bytes of memory
TBlock128 = array[0..3] of cardinal;
/// pointer to a 128-bit buffer
PBlock128 = ^TBlock128;
/// map an infinite array of 128-bit hash values
// - each item consumes 16 bytes of memory
THash128Array = array[ 0 .. MaxInt div SizeOf(THash128) - 1 ] of THash128;
/// pointer to an infinite array of 128-bit hash values
PHash128Array = ^THash128Array;
/// store several 128-bit hash values
// - e.g. MD5 digests
// - consumes 16 bytes of memory per item
THash128DynArray = array of THash128;
/// map a 128-bit hash as an array of lower bit size values
// - consumes 16 bytes of memory
THash128Rec = packed record
case integer of
0: (
Lo, Hi: Int64);
1: (
L, H: QWord);
2: (
i0, i1, i2, i3: integer);
3: (
c0, c1, c2 ,c3: cardinal);
4: (
c: TBlock128);
5: (
b: THash128);
6: (
w: array[0..7] of word);
7: (
l64, h64: Int64Rec);
8: (
guid: TGuid);
end;
/// pointer to 128-bit hash map variable record
PHash128Rec = ^THash128Rec;
/// map an infinite array of 256-bit hash values
// - each item consumes 32 bytes of memory
THash256Array = array[ 0 .. MaxInt div SizeOf(THash256) - 1 ] of THash256;
/// pointer to an infinite array of 256-bit hash values
PHash256Array = ^THash256Array;
/// store several 256-bit hash values
// - e.g. SHA-256 digests, TEccSignature results, or array[0..7] of cardinal
// - consumes 32 bytes of memory per item
THash256DynArray = array of THash256;
/// map a 256-bit hash as an array of lower bit size values
// - consumes 32 bytes of memory
THash256Rec = packed record
case integer of
0: (
Lo, Hi: THash128);
1: (
d0, d1, d2, d3: Int64);
2: (
i0, i1, i2, i3, i4, i5, i6, i7: integer);
3: (
c0, c1: TBlock128);
4: (
b: THash256);
5: (
q: array[0..3] of QWord);
6: (
c: array[0..7] of cardinal);
7: (
w: array[0..15] of word);
8: (
l, h: THash128Rec);
9: (
sha1: THash160);
end;
/// pointer to 256-bit hash map variable record
PHash256Rec = ^THash256Rec;
/// map an infinite array of 512-bit hash values
// - each item consumes 64 bytes of memory
THash512Array = array[ 0 .. MaxInt div SizeOf(THash512) - 1 ] of THash512;
/// pointer to an infinite array of 512-bit hash values
PHash512Array = ^THash512Array;
/// store several 512-bit hash values
// - e.g. SHA-512 digests, or array[0..15] of cardinal
// - consumes 64 bytes of memory per item
THash512DynArray = array of THash512;
/// map a 512-bit hash as an array of lower bit size values
// - consumes 64 bytes of memory
THash512Rec = packed record
case integer of
0: (
Lo, Hi: THash256);
1: (
h0, h1, h2, h3: THash128);
2: (
d0, d1, d2, d3, d4, d5, d6, d7: Int64);
3: (
i0, i1, i2, i3, i4, i5, i6, i7,
i8, i9, i10, i11, i12, i13, i14, i15: integer);
4: (
c0, c1, c2, c3: TBlock128);
5: (
b: THash512);
6: (
b160: THash160);
7: (
b384: THash384);
8: (
w: array[0..31] of word);
9: (
c: array[0..15] of cardinal);
10: (
i: array[0..7] of Int64);
11: (
q: array[0..7] of QWord);
12: (
r: array[0..3] of THash128Rec);
13: (
l, h: THash256Rec);
end;
/// pointer to 512-bit hash map variable record
PHash512Rec = ^THash512Rec;
/// returns TRUE if all 16 bytes of this 128-bit buffer equal zero
// - e.g. a MD5 digest, or an AES block
function IsZero(const dig: THash128): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if all 16 bytes of both 128-bit buffers do match
// - e.g. a MD5 digest, or an AES block
// - this function is not sensitive to any timing attack, so is designed
// for cryptographic purpose - and it is also branchless therefore fast
function IsEqual(const A, B: THash128): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fill all 16 bytes of this 128-bit buffer with zero
// - may be used to cleanup stack-allocated content
// ! ... finally FillZero(digest); end;
procedure FillZero(out dig: THash128); overload;
/// fast O(n) search of a 128-bit item in an array of such values
function Hash128Index(P: PHash128Rec; Count: integer; h: PHash128Rec): integer;
/// add a 128-bit item in an array of such values
function AddHash128(var Arr: THash128DynArray; const V: THash128; var Count: integer): PtrInt;
/// returns TRUE if all 20 bytes of this 160-bit buffer equal zero
// - e.g. a SHA-1 digest
function IsZero(const dig: THash160): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if all 20 bytes of both 160-bit buffers do match
// - e.g. a SHA-1 digest
// - this function is not sensitive to any timing attack, so is designed
// for cryptographic purpose
function IsEqual(const A, B: THash160): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fill all 20 bytes of this 160-bit buffer with zero
// - may be used to cleanup stack-allocated content
// ! ... finally FillZero(digest); end;
procedure FillZero(out dig: THash160); overload;
/// returns TRUE if all 32 bytes of this 256-bit buffer equal zero
// - e.g. a SHA-256 digest, or a TEccSignature result
function IsZero(const dig: THash256): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if all 32 bytes of both 256-bit buffers do match
// - e.g. a SHA-256 digest, or a TEccSignature result
// - this function is not sensitive to any timing attack, so is designed
// for cryptographic purpose
function IsEqual(const A, B: THash256): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fast O(n) search of a 256-bit item in an array of such values
function Hash256Index(P: PHash256Rec; Count: integer; h: PHash256Rec): integer;
/// fill all 32 bytes of this 256-bit buffer with zero
// - may be used to cleanup stack-allocated content
// ! ... finally FillZero(digest); end;
procedure FillZero(out dig: THash256); overload;
/// returns TRUE if all 48 bytes of this 384-bit buffer equal zero
// - e.g. a SHA-384 digest
function IsZero(const dig: THash384): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if all 48 bytes of both 384-bit buffers do match
// - e.g. a SHA-384 digest
// - this function is not sensitive to any timing attack, so is designed
// for cryptographic purpose
function IsEqual(const A, B: THash384): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fill all 32 bytes of this 384-bit buffer with zero
// - may be used to cleanup stack-allocated content
// ! ... finally FillZero(digest); end;
procedure FillZero(out dig: THash384); overload;
/// returns TRUE if all 64 bytes of this 512-bit buffer equal zero
// - e.g. a SHA-512 digest
function IsZero(const dig: THash512): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if all 64 bytes of both 512-bit buffers do match
// - e.g. two SHA-512 digests
// - this function is not sensitive to any timing attack, so is designed
// for cryptographic purpose
function IsEqual(const A, B: THash512): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// fill all 64 bytes of this 512-bit buffer with zero
// - may be used to cleanup stack-allocated content
// ! ... finally FillZero(digest); end;
procedure FillZero(out dig: THash512); overload;
/// returns TRUE if all bytes of both buffers do match
// - this function is not sensitive to any timing attack, so is designed
// for cryptographic purposes - use CompareMem/CompareMemSmall/CompareMemFixed
// as faster alternatives for general-purpose code
function IsEqual(const A, B; count: PtrInt): boolean; overload;
/// thread-safe move of a 32-bit value using a simple Read-Copy-Update pattern
procedure Rcu32(var src, dst);
/// thread-safe move of a 64-bit value using a simple Read-Copy-Update pattern
procedure Rcu64(var src, dst);
/// thread-safe move of a 128-bit value using a simple Read-Copy-Update pattern
procedure Rcu128(var src, dst);
/// thread-safe move of a pointer value using a simple Read-Copy-Update pattern
procedure RcuPtr(var src, dst);
/// thread-safe move of a memory buffer using a simple Read-Copy-Update pattern
procedure Rcu(var src, dst; len: integer);
{$ifdef ISDELPHI}
/// this function is an intrinsic in FPC
procedure ReadBarrier; {$ifndef CPUINTEL} inline; {$endif}
{$endif ISDELPHI}
/// fast computation of two 64-bit unsigned integers into a 128-bit value
{$ifdef CPUINTEL}
procedure mul64x64(const left, right: QWord; out product: THash128Rec);
{$else}
procedure mul64x64(constref left, right: QWord; out product: THash128Rec); inline;
{$endif CPUINTEL}
{ ************ Low-level Functions Manipulating Bits }
/// retrieve a particular bit status from a bit array
// - this function can't be inlined, whereas GetBitPtr() function can
function GetBit(const Bits; aIndex: PtrInt): boolean;
/// set a particular bit into a bit array
// - this function can't be inlined, whereas SetBitPtr() function can
procedure SetBit(var Bits; aIndex: PtrInt);
/// unset/clear a particular bit into a bit array
// - this function can't be inlined, whereas UnSetBitPtr() function can
procedure UnSetBit(var Bits; aIndex: PtrInt);
/// retrieve a particular bit status from a bit array
// - GetBit() can't be inlined, whereas this pointer-oriented function can
function GetBitPtr(Bits: pointer; aIndex: PtrInt): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// set a particular bit into a bit array
// - SetBit() can't be inlined, whereas this pointer-oriented function can
procedure SetBitPtr(Bits: pointer; aIndex: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// unset/clear a particular bit into a bit array
// - UnSetBit() can't be inlined, whereas this pointer-oriented function can
procedure UnSetBitPtr(Bits: pointer; aIndex: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// compute the number of bits set in a bit array
// - Count is the number of BITS to check, not the byte size
// - will use fast SSE4.2 popcnt instruction if available on the CPU
function GetBitsCount(const Bits; Count: PtrInt): PtrInt;
/// pure pascal version of GetBitsCountPtrInt()
// - defined just for regression tests - call GetBitsCountPtrInt() instead
// - has optimized asm on x86_64 and i386
function GetBitsCountPas(value: PtrInt): PtrInt;
/// compute how many bits are set in a given pointer-sized integer
// - the PopCnt() intrinsic under FPC doesn't have any fallback on older CPUs,
// and default implementation is 5 times slower than our GetBitsCountPas() on x64
// - this redirected function will use fast SSE4.2 "popcnt" opcode, if available
var GetBitsCountPtrInt: function(value: PtrInt): PtrInt = GetBitsCountPas;
/// compute how many bytes are needed to store a given number of bits
// - e.g. 0 returns 0, 1..8 returns 1, 9..16 returns 2, and so on
function BitsToBytes(bits: byte): byte;
{$ifdef HASINLINE}inline;{$endif}
const
/// could be used to compute the index in a pointer list from its byte position
POINTERSHR = {$ifdef CPU64} 3 {$else} 2 {$endif};
/// could be used to compute the bitmask of a pointer integer
POINTERAND = {$ifdef CPU64} 7 {$else} 3 {$endif};
/// could be used to check all bits on a pointer
POINTERBITS = {$ifdef CPU64} 64 {$else} 32 {$endif};
/// could be used to check all bytes on a pointer
POINTERBYTES = {$ifdef CPU64} 8 {$else} 4 {$endif};
/// could be used to compute the index in a pointer list from its bits position
POINTERSHRBITS = {$ifdef CPU64} 6 {$else} 5 {$endif};
/// constant array used by GetAllBits() function (when inlined)
ALLBITS_CARDINAL: array[1..32] of cardinal = (
1 shl 1 - 1, 1 shl 2 - 1, 1 shl 3 - 1, 1 shl 4 - 1, 1 shl 5 - 1,
1 shl 6 - 1, 1 shl 7 - 1, 1 shl 8 - 1, 1 shl 9 - 1, 1 shl 10 - 1,
1 shl 11 - 1, 1 shl 12 - 1, 1 shl 13 - 1, 1 shl 14 - 1, 1 shl 15 - 1,
1 shl 16 - 1, 1 shl 17 - 1, 1 shl 18 - 1, 1 shl 19 - 1, 1 shl 20 - 1,
1 shl 21 - 1, 1 shl 22 - 1, 1 shl 23 - 1, 1 shl 24 - 1, 1 shl 25 - 1,
1 shl 26 - 1, 1 shl 27 - 1, 1 shl 28 - 1, 1 shl 29 - 1, 1 shl 30 - 1,
$7fffffff, $ffffffff);
/// returns TRUE if all BitCount bits are set in the input 32-bit cardinal
function GetAllBits(Bits, BitCount: cardinal): boolean;
{$ifdef HASINLINE}inline;{$endif}
type
/// fast access to 8-bit integer bits
// - compiler will generate bt/btr/bts opcodes - note: they may be slow when
// applied on a memory location, but not on a byte value (register)
TBits8 = set of 0..7;
PBits8 = ^TBits8;
TBits8Array = array[ 0 .. MaxInt - 1 ] of TBits8;
/// fast access to 32-bit integer bits
// - compiler will generate bt/btr/bts opcodes - note: they may be slow when
// applied on a memory location, but not on an integer value (register)
TBits32 = set of 0..31;
PBits32 = ^TBits32;
/// fast access to 64-bit integer bits
// - compiler will generate bt/btr/bts opcodes - note: they may be slow when
// applied on a memory location, but not on a Int64 value (register)
// - as used by GetBit64/SetBit64/UnSetBit64
TBits64 = set of 0..63;
PBits64 = ^TBits64;
/// retrieve a particular bit status from a 64-bit integer bits (max aIndex is 63)
function GetBit64(const Bits: Int64; aIndex: PtrInt): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// set a particular bit into a 64-bit integer bits (max aIndex is 63)
procedure SetBit64(var Bits: Int64; aIndex: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// unset/clear a particular bit into a 64-bit integer bits (max aIndex is 63)
procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
{ ************ Faster Alternative to RTL Standard Functions }
type
/// the potential features, retrieved from an Intel/AMD CPU
// - cf https://en.wikipedia.org/wiki/CPUID#EAX.3D1:_Processor_Info_and_Feature_Bits
// - is defined on all platforms, so that e.g. an ARM desktop may browse
// Intel-generated logs using TSynLogFile from mormot.core.log.pas
TIntelCpuFeature = (
{ CPUID EAX=1 into EDX, ECX }
cfFPU, cfVME, cfDE, cfPSE, cfTSC, cfMSR, cfPAE, cfMCE,
cfCX8, cfAPIC, cf_d10, cfSEP, cfMTRR, cfPGE, cfMCA, cfCMOV,
cfPAT, cfPSE36, cfPSN, cfCLFSH, cf_d20, cfDS, cfACPI, cfMMX,
cfFXSR, cfSSE, cfSSE2, cfSS, cfHTT, cfTM, cfIA64, cfPBE,
cfSSE3, cfCLMUL, cfDS64, cfMON, cfDSCPL, cfVMX, cfSMX, cfEST,
cfTM2, cfSSSE3, cfCID, cfSDBG, cfFMA, cfCX16, cfXTPR, cfPDCM,
cf_c16, cfPCID, cfDCA, cfSSE41, cfSSE42, cfX2A, cfMOVBE, cfPOPCNT,
cfTSC2, cfAESNI, cfXS, cfOSXS, cfAVX, cfF16C, cfRAND, cfHYP,
{ extended features CPUID EAX=7,ECX=0 into EBX, ECX, EDX }
cfFSGS, cfTSCADJ, cfSGX, cfBMI1, cfHLE, cfAVX2, cfFDPEO, cfSMEP,
cfBMI2, cfERMS, cfINVPCID, cfRTM, cfPQM, cfFPUSEG, cfMPX, cfPQE,
cfAVX512F, cfAVX512DQ, cfRDSEED, cfADX, cfSMAP, cfAVX512IFMA, cfPCOMMIT,
cfCLFLUSH, cfCLWB, cfIPT, cfAVX512PF, cfAVX512ER, cfAVX512CD, cfSHA,
cfAVX512BW, cfAVX512VL, cfPREFW1, cfAVX512VBMI, cfUMIP, cfPKU, cfOSPKE,
cfWAITPKG, cfAVX512VBMI2, cfCETSS, cfGFNI, cfVAES, cfVCLMUL, cfAVX512NNI,
cfAVX512BITALG, cfTMEEN, cfAVX512VPC, cf_c15, cfFLP, cfMPX0, cfMPX1,
cfMPX2, cfMPX3, cfMPX4, cfRDPID, cfKL, cfBUSLOCK, cfCLDEMOTE, cf_c26,
cfMOVDIRI, cfMOVDIR64B, cfENQCMD, cfSGXLC, cfPKS, cf_d0, cfSGXKEYS,
cfAVX512NNIW, cfAVX512MAPS, cfFSRM, cfUINTR, cf_d6, cf_d7, cfAVX512VP2I,
cfSRBDS, cfMDCLR, cfTSXABRT, cf_d12, cfTSXFA, cfSER, cfHYBRID,
cfTSXLDTRK, cf_d17, cfPCFG, cfLBR, cfIBT, cf_d21, cfAMXBF16, cfAVX512FP16,
cfAMXTILE, cfAMXINT8, cfIBRSPB, cfSTIBP, cfL1DFL, cfARCAB, cfCORCAB, cfSSBD,
{ extended features CPUID EAX=7,ECX=1 into EAX, EDX }
cfSHA512, cfSM3, cfSM4, cfRAOINT, cfAVXVNNI, cfAVX512BF16, cfLASS,
cfCMPCCXADD, cfAPMEL, cf_a9, cfFZLREPM, cfFSREPS, cfFSREPC, cf_a13, cf_a14,
cf_a15, cf_a16, cfFRED, cfLKGS, cfWRMSRNS, cf_a20, cfAMXFP16, cfHRESET,
cfAVXIFMA, cf_a24, cf_a25, cfLAM, cfMSRLIST, cf_a28, cf_a29, cf_a30, cf_a31,
cf__d0, cf_d1, cf_d2, cf_d3, cfAVXVNN8, cfAVXNECVT, cf__d6, cf__d7, cfAMXCPLX,
cf_d9, cfAVXVNNI16, cf_d11, cf__d12, cf_d13, cfPREFETCHI, cf_d15, cf_d16,
cfUIRETUIF, cfCETSSS, cfAVX10, cf__d20, cf_APXF, cf_d22, cf_d23, cf_d24,
cf_d25, cf_d26, cf_d27, cf_d28, cf_d29, cf_d30, cf_d31);
/// all CPU features flags, as retrieved from an Intel/AMD CPU
TIntelCpuFeatures = set of TIntelCpuFeature;
/// the supported AVX10 Converged Vector ISA bit sizes
TIntelAvx10Vector = set of (
av128, av256, av512);
/// the AVX10 Converged Vector ISA features
TIntelAvx10Features = record
/// maximum supported sub-leaf
MaxSubLeaf: cardinal;
/// the ISA version (>= 1)
Version: byte;
/// bit vector size support
Vector: TIntelAvx10Vector;
end;
/// 32-bit ARM Hardware capabilities
// - merging AT_HWCAP and AT_HWCAP2 flags as reported by
// github.com/torvalds/linux/blob/master/arch/arm/include/uapi/asm/hwcap.h
// - is defined on all platforms for cross-system use
TArm32HwCap = (
// HWCAP_* constants
arm32SWP, arm32HALF, arm32THUMB, arm3226BIT, arm32FAST_MULT, arm32FPA,
arm32VFP, arm32EDSP, arm32JAVA, arm32IWMMXT, arm32CRUNCH, arm32THUMBEE,
arm32NEON, arm32VFPv3, arm32VFPv3D16, arm32TLS, arm32VFPv4, arm32IDIVA,
arm32IDIVT, arm32VFPD32, arm32LPAE, arm32EVTSTRM,
arm32_22, arm32_23, arm32_24, arm32_25, arm32_26, arm32_27, arm32_28,
arm32_29, arm32_30, arm32_31,
// HWCAP2_* constants
arm32AES, arm32PMULL, arm32SHA1, arm32SHA2, arm32CRC32);
TArm32HwCaps = set of TArm32HwCap;
/// 64-bit AARCH64 Hardware capabilities
// - merging AT_HWCAP and AT_HWCAP2 flags as reported by
// github.com/torvalds/linux/blob/master/arch/arm64/include/uapi/asm/ahccap.h
// - is defined on all platforms for cross-system use
TArm64HwCap = (
// HWCAP_* constants
arm64FP, arm64ASIMD, arm64EVTSTRM, arm64AES, arm64PMULL,
arm64SHA1, arm64SHA2, arm64CRC32, arm64ATOMICS, arm64FPHP, arm64ASIMDHP,
arm64CPUID, arm64ASIMDRDM, arm64JSCVT, arm64FCMA, arm64LRCPC, arm64DCPOP,
arm64SHA3, arm64SM3, arm64SM4, arm64ASIMDDP, arm64SHA512, arm64SVE,
arm64ASIMDFHM, arm64DIT, arm64USCAT, arm64ILRCPC, arm64FLAGM, arm64SSBS,
arm64SB, arm64PACA, arm64PACG,
// HWCAP2_* constants
arm64DCPODP, arm64SVE2, arm64SVEAES, arm64SVEPMULL, arm64SVEBITPERM,
arm64SVESHA3, arm64SVESM4, arm64FLAGM2, arm64FRINT, arm64SVEI8MM,
arm64SVEF32MM, arm64SVEF64MM, arm64SVEBF16, arm64I8MM,
arm64BF16, arm64DGH, arm64RNG, arm64BTI, arm64MTE);
TArm64HwCaps = set of TArm64HwCap;
{$ifdef CPUARM}
TArmHwCap = TArm32HwCap;
TArmHwCaps = TArm32HwCaps;
const
ahcAES = arm32AES;
ahcPMULL = arm32PMULL;
ahcSHA1 = arm32SHA1;
ahcSHA2 = arm32SHA2;
ahcCRC32 = arm32CRC32;
{$endif CPUARM}
{$ifdef CPUAARCH64}
TArmHwCap = TArm64HwCap;
TArmHwCaps = TArm64HwCaps;
const
ahcAES = arm64AES;
ahcPMULL = arm64PMULL;
ahcSHA1 = arm64SHA1;
ahcSHA2 = arm64SHA2;
ahcCRC32 = arm64CRC32;
{$endif CPUAARCH64}
{$ifdef CPUARM3264}
var
/// the low-level ARM/AARCH64 CPU features retrieved from system.envp
// - text from CpuInfoFeatures may not be accurate on oldest kernels
CpuFeatures: TArmHwCaps;
{$endif CPUARM3264}
/// cross-platform wrapper function to check AES HW support on Intel or ARM
function HasHWAes: boolean;
{$ifdef CPUINTEL}
var
/// the available Intel/AMD CPU features, as recognized at program startup
// - on LINUX, consider CpuInfoArm or the textual CpuInfoFeatures from
// mormot.core.os.pas
CpuFeatures: TIntelCpuFeatures;
/// the detected AVX10 Converged Vector ISA features
// - only set if cfAVX10 is part of CpuFeatures
CpuAvx10: TIntelAvx10Features;
/// compute 32-bit random number generated by modern Intel CPU hardware
// - using NIST SP 800-90A and FIPS 140-2 compliant RDRAND Intel x86/x64 opcode
// - caller should ensure that cfSSE42 is included in CpuFeatures flags
// - you should rather call XorEntropy() which offers additional sources
function RdRand32: cardinal; overload;
/// XOR a memory buffer with some random generated by modern Intel CPU
// - n is the number of 32-bit slots in the supplied buffer to fill
// - will do nothing if cfSSE42 is not available on this CPU
procedure RdRand32(buffer: PCardinal; n: integer); overload;
/// returns the 64-bit Intel Time Stamp Counter (TSC)
// - could be used as entropy source for randomness - use TPrecisionTimer if
// you expect a cross-platform and cross-CPU high resolution performance counter
function Rdtsc: Int64;
/// compatibility function, to be implemented according to the running CPU
// - expect the same result as the homonymous Win32 API function, i.e.
// returns I + 1, and store I + 1 within I in an atomic/tread-safe way
// - FPC will define this function as intrinsic for non-Intel CPUs
function InterlockedIncrement(var I: integer): integer;
/// compatibility function, to be implemented according to the running CPU
// - expect the same result as the homonymous Win32 API function, i.e.
// returns I - 1, and store I - 1 within I in an atomic/tread-safe way
// - FPC will define this function as intrinsic for non-Intel CPUs
function InterlockedDecrement(var I: integer): integer;
/// slightly faster than InterlockedIncrement() when you don't need the result
procedure LockedInc32(int32: PInteger);
/// slightly faster than InterlockedDecrement() when you don't need the result
procedure LockedDec32(int32: PInteger);
/// slightly faster than InterlockedIncrement64()
procedure LockedInc64(int64: PInt64);
// defined here for mormot.test.base only
function GetBitsCountSSE42(value: PtrInt): PtrInt;
// defined here for mormot.test.base only
// - use instead global crc32c() variable
function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
{$else}
/// redirect to FPC InterlockedIncrement() on non Intel CPU
procedure LockedInc32(int32: PInteger); inline;
/// redirect to FPC InterlockedDecrement() on non Intel CPU
procedure LockedDec32(int32: PInteger); inline;
/// redirect to FPC InterlockedIncrement64() on non Intel CPU
procedure LockedInc64(int64: PInt64); inline;
{$endif CPUINTEL}
/// low-level string reference counter unprocess
// - caller should have tested that refcnt>=0
// - returns true if the managed variable should be released (i.e. refcnt was 1)
function StrCntDecFree(var refcnt: TStrCnt): boolean;
{$ifndef CPUINTEL} inline; {$endif}
/// low-level dynarray reference counter unprocess
// - caller should have tested that refcnt>=0
function DACntDecFree(var refcnt: TDACnt): boolean;
{$ifndef CPUINTEL} inline; {$endif}
/// low-level string reference counter process
procedure StrCntAdd(var refcnt: TStrCnt; increment: TStrCnt);
{$ifdef HASINLINE} inline; {$endif}
/// low-level dynarray reference counter process
procedure DACntAdd(var refcnt: TDACnt; increment: TDACnt);
{$ifdef HASINLINE} inline; {$endif}
/// fast atomic compare-and-swap operation on a pointer-sized integer value
// - via Intel/AMD custom asm or FPC RTL InterlockedCompareExchange(pointer)
// - true if Target was equal to Comparand, and Target set to NewValue
// - used e.g. as thread-safe atomic operation for TLightLock/TRWLock
// - Target should be aligned, which is the case when defined as a class field
function LockedExc(var Target: PtrUInt; NewValue, Comperand: PtrUInt): boolean;
{$ifndef CPUINTEL} inline; {$endif}
/// fast atomic addition operation on a pointer-sized integer value
// - via Intel/AMD custom asm or FPC RTL InterlockedExchangeAdd(pointer)
// - Target should be aligned, which is the case when defined as a class field
procedure LockedAdd(var Target: PtrUInt; Increment: PtrUInt);
{$ifndef CPUINTEL} inline; {$endif}
/// fast atomic substraction operation on a pointer-sized integer value
// - via Intel/AMD custom asm or FPC RTL InterlockedExchangeAdd(-pointer)
// - Target should be aligned, which is the case when defined as a class field
procedure LockedDec(var Target: PtrUInt; Decrement: PtrUInt);
{$ifndef CPUINTEL} inline; {$endif}
/// fast atomic addition operation on a 32-bit integer value
// - via Intel/AMD custom asm or FPC RTL InterlockedExchangeAdd(pointer)
// - Target should be aligned, which is the case when defined as a class field
procedure LockedAdd32(var Target: cardinal; Increment: cardinal);
{$ifndef CPUINTEL} inline; {$endif}
{$ifdef ISDELPHI}
/// return the position of the leftmost set bit in a 32-bit value
// - returns 255 if c equals 0
// - this function is an intrinsic on FPC
function BSRdword(c: cardinal): cardinal;
/// return the position of the leftmost set bit in a 64-bit value
// - returns 255 if q equals 0
// - this function is an intrinsic on FPC
function BSRqword(const q: Qword): cardinal;
{$endif ISDELPHI}
{$ifdef ASMINTEL}
{$ifdef ASMX64} // will define its own self-dispatched SSE2/AVX functions
type
/// most common x86_64 CPU abilities, used e.g. by FillCharFast/MoveFast
// - cpuHaswell identifies Intel/AMD AVX2+BMI support at Haswell level
// as expected e.g. by IsValidUtf8Avx2/Base64EncodeAvx2 dedicated asm
// - won't include ERMSB flag because it is not propagated within some VMs
TX64CpuFeatures = set of (
cpuAVX, cpuAVX2, cpuHaswell);
var
/// internal flags used by FillCharFast - easier from asm that CpuFeatures
X64CpuFeatures: TX64CpuFeatures;
{$ifdef ASMX64AVXNOCONST}
/// simdjson asm as used by mormot.core.unicode on Haswell for FPC IsValidUtf8()
function IsValidUtf8Avx2(source: PUtf8Char; sourcelen: PtrInt): boolean;
// avx2 asm as used by mormot.core.buffers for Base64EncodeMain/Base64DecodeMain
procedure Base64EncodeAvx2(var b: PAnsiChar; var blen: PtrUInt; var b64: PAnsiChar);
procedure Base64DecodeAvx2(var b64: PAnsiChar; var b64len: PtrInt; var b: PAnsiChar);
{$endif ASMX64AVXNOCONST}
{$endif ASMX64}
/// our fast version of FillChar() on Intel/AMD
// - on Intel i386/x86_64, will use fast SSE2/AVX instructions (if available)
// - on non-Intel CPUs, it will fallback to the default RTL FillChar()
// - note: Delphi RTL is far from efficient: on i386 the FPU is slower/unsafe,
// and on x86_64, ERMS is wrongly used even for small blocks
// - on ARM/AARCH64 POSIX, mormot.core.os would redirect to optimized libc
procedure FillcharFast(var dst; cnt: PtrInt; value: byte);
/// our fast version of move() on Intel/AMD
// - on Delphi Intel i386/x86_64, will use fast SSE2 instructions (if available)
// - FPC i386 has fastmove.inc which is faster than our SSE2/ERMS version
// - FPC x86_64 RTL is slower than our SSE2/AVX asm
// - on non-Intel CPUs, it will fallback to the default RTL Move()
// - on ARM/AARCH64 POSIX, mormot.core.os would redirect to optimized libc
{$ifdef FPC_X86}
var MoveFast: procedure(const Source; var Dest; Count: PtrInt) = Move;
{$else}
procedure MoveFast(const src; var dst; cnt: PtrInt);
{$endif FPC_X86}
{$else}
// fallback to RTL versions on non-INTEL or PIC platforms by default
// and mormot.core.os.posix.inc redirects them to libc memset/memmove
var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte) = FillChar;
var MoveFast: procedure(const Source; var Dest; Count: PtrInt) = Move;
{$endif ASMINTEL}
/// Move() with one-by-one byte copy
// - never redirect to MoveFast() so could be used when data overlaps
procedure MoveByOne(Source, Dest: Pointer; Count: PtrUInt);
{$ifdef HASINLINE} inline; {$endif}
/// perform a MoveFast then fill the Source buffer with zeros
// - could be used e.g. to quickly move a managed record content into a newly
// allocated stack variable with no reference counting
procedure MoveAndZero(Source, Dest: Pointer; Count: PtrUInt);
/// fill all bytes of a memory buffer with zero
// - just redirect to FillCharFast(..,...,0)
procedure FillZero(var dest; count: PtrInt); overload;
{$ifdef HASINLINE}inline;{$endif}
/// fill first bytes of a memory buffer with zero
// - Length is expected to be not 0, typically in 1..8 range
// - when inlined, is slightly more efficient than regular FillZero/FillCharFast
procedure FillZeroSmall(P: pointer; Length: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// binary comparison of buffers, returning <0, 0 or >0 results
// - caller should ensure that P1<>nil, P2<>nil and L>0
// - on x86_64, will use a fast SSE2 asm version of the C function memcmp()
// (which is also used by CompareMem and CompareBuf)
// - on other platforms, run a simple but efficient per-byte comparison
function MemCmp(P1, P2: PByteArray; L: PtrInt): integer;
{$ifndef CPUX64} {$ifdef HASINLINE} inline; {$endif} {$endif}
/// our fast version of CompareMem()
// - tuned asm for x86, call MemCmpSse2 for x64, or fallback to tuned pascal
function CompareMem(P1, P2: Pointer; Length: PtrInt): boolean;
{$ifdef CPUX64}inline;{$endif}
/// overload wrapper of MemCmp() to compare a RawByteString vs a memory buffer
// - will first check length(P1)=P2Len then call MemCmp()
function CompareBuf(const P1: RawByteString; P2: Pointer; P2Len: PtrInt): integer;
overload; {$ifdef HASINLINE}inline;{$endif}
/// overload wrapper to SortDynArrayRawByteString(P1, P2)
// - won't involve any code page - so may be safer e.g. on FPC
function CompareBuf(const P1, P2: RawByteString): integer;
overload; {$ifdef HASINLINE}inline;{$endif}
/// overload wrapper to SortDynArrayRawByteString(P1, P2) = 0
// - won't involve any code page - so may be safer e.g. on FPC
function EqualBuf(const P1, P2: RawByteString): boolean;
overload; {$ifdef HASINLINE}inline;{$endif}
{$ifdef HASINLINE}
function CompareMemFixed(P1, P2: Pointer; Length: PtrInt): boolean; inline;
{$else}
/// a CompareMem()-like function designed for small and fixed-sized content
// - here, Length is expected to be a constant value - typically from SizeOf() -
// so that inlining has better performance than calling the CompareMem() function
var CompareMemFixed: function(P1, P2: Pointer; Length: PtrInt): boolean = CompareMem;
{$endif HASINLINE}
/// a CompareMem()-like function designed for small (a few bytes) content
// - to be efficiently inlined in processing code
function CompareMemSmall(P1, P2: Pointer; Length: PtrInt): boolean;
{$ifdef HASINLINE}inline;{$endif}
{$ifndef CPUX86}
/// low-level efficient pure pascal function used when inlining PosEx()
// - not to be called directly
function PosExPas(pSub, p: PUtf8Char; Offset: PtrUInt): PtrInt;
{$endif CPUX86}
{$ifdef UNICODE}
/// low-level efficient pure pascal function used when inlining PosExString()
// - not to be called directly
function PosExStringPas(pSub, p: PChar; Offset: PtrUInt): PtrInt;
{$endif UNICODE}
/// faster RawUtf8 Equivalent of standard StrUtils.PosEx
function PosEx(const SubStr, S: RawUtf8; Offset: PtrUInt = 1): PtrInt;
{$ifndef CPUX86}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// our own PosEx() function dedicated to RTL string process
// - Delphi XE or older don't support Pos() with an Offset
function PosExString(const SubStr, S: string; Offset: PtrUInt = 1): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// optimized version of PosEx() with search text as one AnsiChar
// - will use fast SSE2 asm on i386 and x86_64
function PosExChar(Chr: AnsiChar; const Str: RawUtf8): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// fast retrieve the position of a given character in a #0 ended buffer
// - will use fast SSE2 asm on i386 and x86_64
function PosChar(Str: PUtf8Char; Chr: AnsiChar): PUtf8Char; overload;
{$ifndef CPUX64}{$ifdef FPC}inline;{$endif}{$endif}
/// fast retrieve the position of a given character in a #0 ended buffer
// - will use fast SSE2 asm on i386 and x86_64
function PosChar(Str: PUtf8Char; StrLen: PtrInt; Chr: AnsiChar): PUtf8Char; overload;
{$ifdef HASINLINE}inline;{$endif}
{$ifndef PUREMORMOT2}
/// fast dedicated RawUtf8 version of Trim()
// - in the middle of UI code, consider using TrimU() which won't have name
// collision ambiguity as with SysUtils' homonymous function
function Trim(const S: RawUtf8): RawUtf8;
{$ifdef HASINLINE}inline;{$endif}
{$endif PUREMORMOT2}
/// fast dedicated RawUtf8 version of Trim()
// - should be used for RawUtf8 instead of SysUtils' Trim() which is ambiguous
// with the main String/UnicodeString type of Delphi 2009+
// - in mORMot 1.18, there was a Trim() function but it was confusing
function TrimU(const S: RawUtf8): RawUtf8;
/// fast dedicated RawUtf8 version of s := Trim(s)
procedure TrimSelf(var S: RawUtf8);
/// single-allocation (therefore faster) alternative to Trim(copy())
procedure TrimCopy(const S: RawUtf8; start, count: PtrInt;
var result: RawUtf8);
/// returns the left part of a RawUtf8 string, according to SepStr separator
// - if SepStr is found, returns Str first chars until (and excluding) SepStr
// - if SepStr is not found, returns Str
function Split(const Str, SepStr: RawUtf8; StartPos: PtrInt = 1): RawUtf8; overload;
/// buffer-overflow safe version of StrComp(), to be used with PUtf8Char/PAnsiChar
function StrComp(Str1, Str2: pointer): PtrInt;
{$ifndef CPUX86}{$ifdef HASINLINE}inline;{$endif}{$endif}
/// our fast version of StrComp(), to be used with PWideChar
function StrCompW(Str1, Str2: PWideChar): PtrInt;
{$ifdef HASINLINE}inline;{$endif}
/// simple version of StrLen(), but which will never read beyond the string
// - this version won't access the memory beyond the string, so may be
// preferred e.g. with valgrid
// - SSE2 StrLen() versions would never read outside a memory page boundary,
// so are safe to use in practice, but may read outside the string buffer
// itself, so may not please paranoid tools like valgrid
function StrLenSafe(S: pointer): PtrInt;
{$ifdef CPU64}inline;{$endif}
/// our fast version of StrLen(), to be used with PUtf8Char/PAnsiChar
// - under x86, will detect SSE2 and use it if available, reaching e.g.
// 37.5 GB/s on a Core i5-13500 under Linux x86_64
// - on ARM/AARCH64 POSIX, mormot.core.os would redirect to optimized libc
{$ifdef CPUX64}
function StrLen(S: pointer): PtrInt;
{$else}
var StrLen: function(S: pointer): PtrInt = StrLenSafe;
{$endif CPUX64}
/// our fast version of StrLen(), to be used with PWideChar
function StrLenW(S: PWideChar): PtrInt;
/// fast go to next text line, ended by #13 or #13#10
// - source is expected to be not nil
// - returns the beginning of next line, or nil if source^=#0 was reached
function GotoNextLine(source: PUtf8Char): PUtf8Char;
{$ifdef HASINLINE}inline;{$endif}
/// fast go to the first char <= #13
// - source is expected to be not nil
function GotoNextControlChar(source: PUtf8Char): PUtf8Char;
{$ifdef HASINLINE}inline;{$endif}
/// return TRUE if the supplied buffer only contains 7-bits Ansi characters
function IsAnsiCompatible(PC: PAnsiChar): boolean; overload;
/// return TRUE if the supplied buffer only contains 7-bits Ansi characters
function IsAnsiCompatible(PC: PAnsiChar; Len: PtrUInt): boolean; overload;
/// return TRUE if the supplied UTF-16 buffer only contains 7-bits Ansi characters
function IsAnsiCompatibleW(PW: PWideChar): boolean; overload;
/// return TRUE if the supplied text only contains 7-bits Ansi characters
function IsAnsiCompatible(const Text: RawByteString): boolean; overload;
{$ifdef HASINLINE}inline;{$endif}
/// return TRUE if the supplied UTF-16 buffer only contains 7-bits Ansi characters
function IsAnsiCompatibleW(PW: PWideChar; Len: PtrInt): boolean; overload;
type
/// 32-bit Pierre L'Ecuyer software (random) generator
// - cross-compiler and cross-platform efficient randomness generator, very
// fast with a much better distribution than Delphi system's Random() function
// see https://www.gnu.org/software/gsl/doc/html/rng.html#c.gsl_rng_taus2
// - used by thread-safe Random32/RandomBytes, storing 16 bytes per thread - a
// stronger algorithm like Mersenne Twister (as used by FPC RTL) requires 5KB
// - SeedGenerator() makes it a sequence generator - or encryptor via Fill()
// - when used as random generator (default when initialized with 0), Seed()
// will gather and hash some system entropy to initialize the internal state
{$ifdef USERECORDWITHMETHODS}
TLecuyer = record
{$else}
TLecuyer = object
{$endif USERECORDWITHMETHODS}
public
rs1, rs2, rs3, seedcount: cardinal;
/// force a random seed of the generator from current system state
// - as executed by the Next method at thread startup, and after 2^32 values
// - calls XorEntropy(), so RdRand32/Rdtsc opcodes on Intel/AMD CPUs
procedure Seed(entropy: PByteArray = nil; entropylen: PtrInt = 0);
/// force a well-defined seed of the generator from a fixed initial point
// - to be called before Next/Fill to generate the very same output
// - will generate up to 16GB of predictable output, then switch to random
procedure SeedGenerator(fixedseed: QWord); overload;
/// force a well-defined seed of the generator from a buffer initial point
// - apply crc32c() over the fixedseed buffer to initialize the generator
procedure SeedGenerator(fixedseed: pointer; fixedseedbytes: integer); overload;
/// compute the next 32-bit generated value with no Seed - internal call
function RawNext: cardinal;
/// compute the next 32-bit generated value
// - will automatically reseed after around 2^32 generated values, which is
// huge but very conservative since this generator has a period of 2^88
function Next: cardinal; overload;
{$ifdef HASSAFEINLINE}inline;{$endif}
/// compute the next 32-bit generated value, in range [0..max-1]
function Next(max: cardinal): cardinal; overload;
{$ifdef HASSAFEINLINE}inline;{$endif}
/// compute a 64-bit integer value
function NextQWord: QWord;
/// compute a 64-bit floating point value
function NextDouble: double;
/// XOR some memory buffer with random bytes
// - when used as sequence generator after SeedGenerator(), dest buffer
// should be filled with zeros before the call if you want to use it as
// generator, but could be applied on any memory buffer for encryption
procedure Fill(dest: pointer; bytes: integer);
/// fill some string[0..size] with 7-bit ASCII random text
procedure FillShort(var dest: ShortString; size: PtrUInt = 255);
/// fill some string[0..31] with 7-bit ASCII random text
procedure FillShort31(var dest: TShort31);
end;
PLecuyer = ^TLecuyer;
/// return the 32-bit Pierre L'Ecuyer software generator for the current thread
// - can be used as an alternative to several Random32 function calls
function Lecuyer: PLecuyer;
/// internal function used e.g. by TLecuyer.FillShort/FillShort31
procedure FillAnsiStringFromRandom(dest: PByteArray; size: PtrUInt);
/// fast compute of some 32-bit random value, using the gsl_rng_taus2 generator
// - this function will use well documented and proven Pierre L'Ecuyer software
// generator - which happens to be faster (and safer) than RDRAND opcode (which
// is used for seeding anyway)
// - consider using TAesPrng.Main.Random32(), which offers cryptographic-level
// randomness, but is twice slower (even with AES-NI)
// - thread-safe and non-blocking function: each thread will maintain its own
// TLecuyer table (note that RTL's system.Random function is not thread-safe)
function Random32: cardinal; overload;
/// fast compute of some 31-bit random value, using the gsl_rng_taus2 generator
// - thread-safe function: each thread will maintain its own TLecuyer table
function Random31: integer;
/// fast compute of a 64-bit random value, using the gsl_rng_taus2 generator
// - thread-safe function: each thread will maintain its own TLecuyer table
function Random64: QWord;
/// fast compute of bounded 32-bit random value, using the gsl_rng_taus2 generator
// - calls internally the overloaded Random32 function, ensuring Random32(max)<max
// - consider using TAesPrng.Main.Random32(), which offers cryptographic-level
// randomness, but is twice slower (even with AES-NI)
// - thread-safe and non-blocking function using a per-thread TLecuyer engine
function Random32(max: cardinal): cardinal; overload;
/// fast compute of a 64-bit random floating point, using the gsl_rng_taus2 generator
// - thread-safe and non-blocking function using a per-thread TLecuyer engine
function RandomDouble: double;
/// fill a memory buffer with random bytes from the gsl_rng_taus2 generator
// - will actually XOR the Dest buffer with Lecuyer numbers
// - consider also the cryptographic-level TAesPrng.Main.FillRandom() method
// - thread-safe and non-blocking function using a per-thread TLecuyer engine
procedure RandomBytes(Dest: PByte; Count: integer);
/// fill some string[31] with 7-bit ASCII random text
// - thread-safe and non-blocking function using a per-thread TLecuyer engine
procedure RandomShort31(var dest: TShort31);
{$ifndef PUREMORMOT2}
/// fill some 32-bit memory buffer with values from the gsl_rng_taus2 generator
// - the destination buffer is expected to be allocated as 32-bit items
procedure FillRandom(Dest: PCardinal; CardinalCount: integer);
{$endif PUREMORMOT2}
/// seed the thread-specific gsl_rng_taus2 Random32 generator
// - by default, gsl_rng_taus2 generator is re-seeded every 2^32 values, which
// is very conservative against the Pierre L'Ecuyer's algorithm period of 2^88
// - you can specify some additional entropy buffer; note that calling this
// function with the same entropy again WON'T seed the generator with the same
// sequence (as with RTL's RandomSeed function), but initiate a new one
// - calls XorEntropy(), so RdRand32/Rdtsc opcodes on Intel/AMD CPUs
// - thread-safe and non-blocking function using a per-thread TLecuyer engine
procedure Random32Seed(entropy: pointer = nil; entropylen: PtrInt = 0);
/// cipher/uncipher some memory buffer using a 64-bit seed and Pierre L'Ecuyer's
// algorithm, and its gsl_rng_taus2 generator
procedure LecuyerEncrypt(key: Qword; var data: RawByteString);
/// retrieve 512-bit of entropy, from system time and current execution state
// - entropy is gathered over several sources like RTL Now(), CreateGuid(),
// current gsl_rng_taus2 Lecuyer state, and RdRand32/Rdtsc low-level Intel opcodes
// - the resulting output is to be hashed - e.g. with DefaultHasher128
// - execution is fast, but not enough as unique seed for a cryptographic PRNG:
// TAesPrng.GetEntropy will call it as one of its entropy sources, in addition
// to system-retrieved randomness from mormot.core.os.pas' XorOSEntropy()
procedure XorEntropy(var e: THash512Rec);
/// convert the endianness of a given unsigned 32-bit integer into BigEndian
function bswap32(a: cardinal): cardinal;
{$ifndef CPUINTEL}inline;{$endif}
/// convert the endianness of a given unsigned 64-bit integer into BigEndian
function bswap64({$ifdef FPC_X86}constref{$else}const{$endif} a: QWord): QWord;
{$ifndef CPUINTEL}inline;{$endif}
/// convert the endianness of an array of unsigned 64-bit integer into BigEndian
// - n is required to be > 0
// - warning: on x86, a should be <> b
procedure bswap64array(a, b: PQWordArray; n: PtrInt);
/// copy one memory buffer to another, swapping the bytes order
// - used e.g. by TBigInt.Load/Save to follow DER big-endian encoding
// - warning: src and dst should not overlap
procedure MoveSwap(dst, src: PByte; n: PtrInt);
/// low-level wrapper to add a callback to a dynamic list of events
// - by default, you can assign only one callback to an Event: but by storing
// it as a dynamic array of events, you can use this wrapper to add one callback
// to this list of events
// - if the event was already registered, do nothing (i.e. won't call it twice)
// - since this function uses an unsafe typeless EventList parameter, you should
// not use it in high-level code, but only as wrapper within dedicated methods
// - will add Event to EventList[] unless Event is already registered
// - is used e.g. by TJsonWriter as such:
// ! ...
// ! fEchos: array of TOnTextWriterEcho;
// ! ...
// ! procedure EchoAdd(const aEcho: TOnTextWriterEcho);
// ! ...
// ! procedure TEchoWriter.EchoAdd(const aEcho: TOnTextWriterEcho);
// ! begin
// ! MultiEventAdd(fEchos,TMethod(aEcho));
// ! end;
// then callbacks are then executed as such:
// ! if fEchos<>nil then
// ! for i := 0 to length(fEchos) - 1 do
// ! fEchos[i](self,fEchoBuf);
// - use MultiEventRemove() to un-register a callback from the list
function MultiEventAdd(var EventList; const Event: TMethod): boolean;
/// low-level wrapper to remove a callback from a dynamic list of events
// - by default, you can assign only one callback to an Event: but by storing
// it as a dynamic array of events, you can use this wrapper to remove one
// callback already registered by MultiEventAdd() to this list of events
// - since this function uses an unsafe typeless EventList parameter, you should
// not use it in high-level code, but only as wrapper within dedicated methods
// - is used e.g. by TJsonWriter as such:
// ! ...
// ! fEchos: array of TOnTextWriterEcho;
// ! ...
// ! procedure EchoRemove(const aEcho: TOnTextWriterEcho);
// ! ...
// ! procedure TJsonWriter.EchoRemove(const aEcho: TOnTextWriterEcho);
// ! begin
// ! MultiEventRemove(fEchos,TMethod(aEcho));
// ! end;
procedure MultiEventRemove(var EventList; const Event: TMethod); overload;
/// low-level wrapper to remove a callback from a dynamic list of events
// - same as the same overloaded procedure, but accepting an EventList[] index
// to identify the Event to be suppressed
procedure MultiEventRemove(var EventList; Index: integer); overload;
/// low-level wrapper to check if a callback is in a dynamic list of events
// - by default, you can assign only one callback to an Event: but by storing
// it as a dynamic array of events, you can use this wrapper to check if
// a callback has already been registered to this list of events
// - used internally by MultiEventAdd() and MultiEventRemove() functions
function MultiEventFind(const EventList; const Event: TMethod): PtrInt;
/// low-level wrapper to add one or several callbacks from another list of events
// - all events of the ToBeAddedList would be added to DestList
// - the list is not checked for duplicates
procedure MultiEventMerge(var DestList; const ToBeAddedList);
/// compare two TMethod instances
function EventEquals(const eventA, eventB): boolean;
{$ifdef HASINLINE}inline;{$endif}
{ ************ Buffers (e.g. Hashing and SynLZ compression) Raw Functions }
type
/// implements a 4KB stack-based storage of some (UTF-8 or binary) content
// - could be used e.g. to make a temporary copy when JSON is parsed in-place
// - call one of the Init() overloaded methods, then Done to release its memory
// - will avoid temporary memory allocation via the heap for up to 4KB of data
// - all Init() methods will allocate 16 more bytes, for a trailing #0 and
// to ensure our fast JSON parsing won't trigger any GPF (since it may read
// up to 4 bytes ahead via its PInteger() trick) or any SSE4.2 function
{$ifdef USERECORDWITHMETHODS}
TSynTempBuffer = record
{$else}
TSynTempBuffer = object
{$endif USERECORDWITHMETHODS}
public
/// the text/binary length, in bytes, excluding the trailing #0
len: PtrInt;
/// where the text/binary is available (and any Source has been copied)
// - equals nil if len=0
buf: pointer;
/// default 4KB buffer allocated on stack - after the len/buf main fields
// - 16 last bytes are reserved to prevent potential buffer overflow,
// so usable length is 4080 bytes
tmp: array[0..4095] of AnsiChar;
/// initialize a temporary copy of the content supplied as RawByteString
// - will also allocate and copy the ending #0 (even for binary)
procedure Init(const Source: RawByteString); overload;
/// initialize a temporary copy of the supplied text buffer, ending with #0
function Init(Source: PUtf8Char): PUtf8Char; overload;
/// initialize a temporary copy of the supplied text buffer
// - also include ending #0 at SourceLen position
procedure Init(Source: pointer; SourceLen: PtrInt); overload;
/// initialize a new temporary buffer of a given number of bytes
// - also include ending #0 at SourceLen position
function Init(SourceLen: PtrInt): pointer; overload;
/// initialize a temporary buffer with the length of the internal stack
function InitOnStack: pointer;
{$ifdef HASINLINE}inline;{$endif}
/// initialize the buffer returning the internal buffer size (4080 bytes)
// - also set len to the internal buffer size
// - could be used e.g. for an API call, first trying with plain temp.Init
// and using temp.buf and temp.len safely in the call, only calling
// temp.Init(expectedsize) if the API returns an insufficient buffer error
function Init: integer; overload;
{$ifdef HASINLINE}inline;{$endif}
/// initialize a new temporary buffer of a given number of random bytes
// - will fill the buffer via RandomBytes() call
function InitRandom(RandomLen: integer): pointer;
/// initialize a new temporary buffer filled with 32-bit integer increasing values
function InitIncreasing(Count: PtrInt; Start: PtrInt = 0): PIntegerArray;
/// initialize a new temporary buffer of a given number of zero bytes
// - if ZeroLen=0, will initialize the whole tmp[] stack buffer to 0
function InitZero(ZeroLen: PtrInt): pointer;
/// inlined wrapper around buf + len
function BufEnd: pointer;
{$ifdef HASINLINE}inline;{$endif}
/// finalize the temporary storage
procedure Done; overload;
{$ifdef HASINLINE}inline;{$endif}
/// finalize the temporary storage, and create a RawUtf8 string from it
procedure Done(EndBuf: pointer; var Dest: RawUtf8); overload;
end;
PSynTempBuffer = ^TSynTempBuffer;
/// logical OR of two memory buffers
// - will perform on all buffer bytes:
// ! Dest[i] := Dest[i] or Source[i];
procedure OrMemory(Dest, Source: PByteArray; size: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// logical XOR of two memory buffers
// - will perform on all buffer bytes:
// ! Dest[i] := Dest[i] xor Source[i];
procedure XorMemory(Dest, Source: PByteArray; size: PtrInt); overload;
{$ifdef HASINLINE}inline;{$endif}
/// logical XOR of two memory buffers into a third
// - will perform on all buffer bytes:
// ! Dest[i] := Source1[i] xor Source2[i];
procedure XorMemory(Dest, Source1, Source2: PByteArray; size: PtrInt); overload;
{$ifdef HASINLINE}inline;{$endif}
/// logical AND of two memory buffers
// - will perform on all buffer bytes:
// ! Dest[i] := Dest[i] and Source[i];
procedure AndMemory(Dest, Source: PByteArray; size: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// returns TRUE if all bytes equal zero
function IsZero(P: pointer; Length: integer): boolean; overload;
/// returns TRUE if all of a few bytes equal zero
// - to be called instead of IsZero() e.g. for 1..8 bytes
function IsZeroSmall(P: pointer; Length: PtrInt): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// compute the line length from a size-delimited source array of chars
// - will use fast SSE2 assembly on x86-64 CPU
// - is likely to read some bytes after the TextEnd buffer, so GetLineSize()
// from mormot.core.text may be preferred, e.g. on memory mapped files
// - expects Text and TextEnd to be not nil - see GetLineSize() instead
function BufferLineLength(Text, TextEnd: PUtf8Char): PtrInt;
{$ifndef CPUX64}{$ifdef HASINLINE}inline;{$endif}{$endif}
type
TCrc32tab = array[0..7, byte] of cardinal;
PCrc32tab = ^TCrc32tab;
/// function prototype to be used for 32-bit hashing of an element
// - it must return a cardinal hash, with as less collision as possible
// - is the function signature of DefaultHasher and InterningHasher
THasher = function(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
/// function prototype to be used for 64-bit hashing of an element
// - it must return a QWord hash, with as less collision as possible
// - is the function signature of DefaultHasher64
THasher64 = function(crc: QWord; buf: PAnsiChar; len: cardinal): QWord;
/// function prototype to be used for 128-bit hashing of an element
// - the input hash buffer is used as seed, and contains the 128-bit result
// - is the function signature of DefaultHasher128
THasher128 = procedure(hash: PHash128; buf: PAnsiChar; len: cardinal);
var
/// 8KB tables used by crc32cfast() function
// - created with a polynom diverse from zlib's crc32() algorithm, but
// compatible with SSE 4.2 crc32 instruction
// - tables content is created from code in initialization section below
// - will also be used internally by SymmetricEncrypt and
// TSynUniqueIdentifierGenerator as 1KB master/reference key tables
crc32ctab: TCrc32tab;
/// 8KB tables used by crc32fast() function
crc32tab: TCrc32tab;
/// compute CRC32C checksum on the supplied buffer on processor-neutral code
// - result is compatible with SSE 4.2 based hardware accelerated instruction
// - will use fast x86/x64 asm or efficient pure pascal implementation on ARM
// - result is not compatible with zlib's crc32() - not the same polynom
// - crc32cfast() is 1.7 GB/s, crc32csse42() is 4.3 GB/s
// - you should use crc32c() function instead of crc32cfast() or crc32csse42()
function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
/// compute CRC32 checksum on the supplied buffer on processor-neutral code
// - result is compatible with zlib's crc32() but not with crc32c/crc32cfast()
function crc32fast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
/// compute CRC32C checksum on the supplied buffer using inlined code
// - if the compiler supports inlining, will compute a slow but safe crc32c
// checksum of the binary buffer, without calling the main crc32c() function
// - may be used e.g. to identify patched executable at runtime, for a licensing
// protection system, or if you don't want to pollute the CPU L1 cache with
// crc32cfast() bigger lookup tables
function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
{$ifdef HASINLINE}inline;{$endif}
/// compute CRC64C checksum on the supplied buffer, cascading two crc32c
// - will use SSE 4.2 or ARMv8 hardware accelerated instruction, if available
// - will combine two crc32c() calls into a single Int64 result
// - by design, such combined hashes cannot be cascaded
function crc64c(buf: PAnsiChar; len: cardinal): Int64;
/// expand a CRC32C checksum on the supplied buffer for 64-bit hashing
// - will use SSE 4.2 or ARMv8 hardware accelerated instruction, if available
// - is the default implementation of DefaultHasher64
function crc32ctwice(seed: QWord; buf: PAnsiChar; len: cardinal): QWord;
/// compute CRC63C checksum on the supplied buffer, cascading two crc32c
// - similar to crc64c, but with 63-bit, so no negative value: may be used
// safely e.g. as mORMot's TID source
// - will use SSE 4.2 or ARMv8 hardware accelerated instruction, if available
// - will combine two crc32c() calls into an unsigned 63-bit Int64 result
// - by design, such combined hashes cannot be cascaded
function crc63c(buf: PAnsiChar; len: cardinal): Int64;
/// compute a 128-bit checksum on the supplied buffer, cascading two crc32c
// - will use SSE 4.2 or ARMv8 hardware accelerated instruction, if available
// - will combine two crc32c() calls into a single TAesBlock result
// - by design, such combined hashes cannot be cascaded
procedure crc128c(buf: PAnsiChar; len: cardinal; out crc: THash128);
/// compute a 256-bit checksum on the supplied buffer using crc32c
// - will use SSE 4.2 or ARMv8 hardware accelerated instruction, if available
// - will combine two crc32c() calls into a single THash256 result
// - by design, such combined hashes cannot be cascaded
procedure crc256c(buf: PAnsiChar; len: cardinal; out crc: THash256);
/// pure pascal function implementing crc32cBy4()
function crc32cBy4fast(crc, value: cardinal): cardinal;
/// compute a proprietary 128-bit CRC of 128-bit binary buffers
// - to be used for regression tests only: crcblocks will use the fastest
// implementation available on the current CPU (e.g. with SSE 4.2 or ARMv8)
procedure crcblocksfast(crc128, data128: PBlock128; count: integer);
/// computation of our 128-bit CRC of a 128-bit binary buffer without SSE4.2
// - to be used for regression tests only: crcblock will use the fastest
// implementation available on the current CPU (e.g. with SSE 4.2 or ARMv8)
procedure crcblockfast(crc128, data128: PBlock128);
/// compute a 128-bit CRC of any binary buffers
// - combine crcblocks() with 4 parallel crc32c() for 1..15 trailing bytes
procedure crc32c128(hash: PHash128; buf: PAnsiChar; len: cardinal);
var
/// compute CRC32C checksum on the supplied buffer
// - result is not compatible with zlib's crc32() - Intel/SCSI CRC32C has not
// same polynom - but will use the fastest mean available, e.g. SSE 4.2 or ARMv8,
// achieve up to 16GB/s with the optimized implementation from mormot.crypt.core
// - you should use this function instead of crc32cfast() or crc32csse42()
crc32c: THasher = crc32cfast;
/// compute CRC32C checksum on one 32-bit unsigned integer
// - can be used instead of crc32c() for inlined process during data acquisition
// - doesn't make "crc := not crc" before and after the computation: caller has
// to start with "crc := cardinal(not 0)" and make "crc := not crc" at the end,
// to compute the very same hash value than regular crc32c()
// - this variable will use the fastest mean available, e.g. SSE 4.2 or ARMv8
crc32cBy4: function(crc, value: cardinal): cardinal = crc32cBy4fast;
/// compute a proprietary 128-bit CRC of a 128-bit binary buffer
// - apply four crc32c() calls on the 128-bit input chunk, into a 128-bit crc
// - its output won't match crc128c() value, which works on 8-bit input
// - will use SSE 4.2 or ARMv8 hardware accelerated instruction, if available
// - is used e.g. by mormot.crypt.core's TAesCfc/TAesOfc/TAesCtc to
// check for data integrity
crcblock: procedure(crc128, data128: PBlock128) = crcblockfast;
/// compute a proprietary 128-bit CRC of 128-bit binary buffers
// - apply four crc32c() calls on the 128-bit input chunks, into a 128-bit crc
// - its output won't match crc128c() value, which works on 8-bit input
// - will use SSE 4.2 or ARMv8 hardware accelerated instruction, if available
// - is used e.g. by crc32c128 or mormot.crypt.ecc's TEcdheProtocol.ComputeMAC
// for macCrc128c or TAesAbstractAead.MacCheckError
crcblocks: procedure(crc128, data128: PBlock128; count: integer) = crcblocksfast;
/// compute CRC32 checksum on the supplied buffer
// - mormot.lib.z.pas will replace with its official (may be faster) version
crc32: THasher = crc32fast;
/// compute ADLER32 checksum on the supplied buffer
// - is only available if mormot.lib.z.pas unit is included in the project
adler32: THasher;
/// compute CRC16-CCITT checkum on the supplied buffer
// - i.e. 16-bit CRC-CCITT, with polynomial x^16 + x^12 + x^5 + 1 ($1021)
// and $ffff as initial value
// - this version is not optimized for speed, but for correctness
function crc16(Data: PAnsiChar; Len: integer): cardinal;
// our custom efficient 32-bit hash/checksum function
// - a Fletcher-like checksum algorithm, not a hash function: has less colisions
// than Adler32 for short strings, but more than xxhash32 or crc32/crc32c
// - written in simple plain pascal, with no L1 CPU cache pollution, but we
// also provide optimized x86/x64 assembly versions, since the algorithm is used
// heavily e.g. for TDynArray binary serialization, TRestStorageInMemory
// binary persistence, or CompressSynLZ/StreamSynLZ/FileSynLZ
// - some numbers on Linux x86_64:
// $ 2500 xxhash32 in 1.34ms i.e. 1861504/s or 3.8 GB/s
// $ 2500 crc32c in 943us i.e. 2651113/s or 5.5 GB/s (SSE4.2 disabled)
// $ 2500 hash32 in 707us i.e. 3536067/s or 7.3 GB/s
// $ 2500 crc32c in 387us i.e. 6459948/s or 13.4 GB/s (SSE4.2 enabled)
function Hash32(Data: PCardinalArray; Len: integer): cardinal; overload;
// our custom efficient 32-bit hash/checksum function
// - a Fletcher-like checksum algorithm, not a hash function: has less colisions
// than Adler32 for short strings, but more than xxhash32 or crc32/crc32c
// - overloaded function using RawByteString for binary content hashing,
// whatever the codepage is
function Hash32(const Text: RawByteString): cardinal; overload;
{$ifdef HASINLINE}inline;{$endif}
/// standard Kernighan & Ritchie hash from "The C programming Language", 3rd edition
// - simple and efficient code, but too much collisions for THasher
// - kr32() is 898.8 MB/s - crc32cfast() 1.7 GB/s, crc32csse42() 4.3 GB/s
function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
/// simple FNV-1a hashing function
// - when run over our regression suite, is similar to crc32c() about collisions,
// and 4 times better than kr32(), but also slower than the others
// - fnv32() is 715.5 MB/s - kr32() 898.8 MB/s
// - this hash function should not be usefull, unless you need several hashing
// algorithms at once (e.g. if crc32c with diverse seeds is not enough)
function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
/// perform very fast xxHash hashing in 32-bit mode
// - will use optimized asm for x86/x64, or a pascal version on other CPUs
function xxHash32(crc: cardinal; P: PAnsiChar; len: cardinal): cardinal;
/// shuffle a 32-bit value using the last stage of xxHash32 algorithm
// - is a cascade of binary shifts and multiplications by prime numbers
// - see also (c * KNUTH_HASH32_MUL) shr (32 - bits) as weaker alternative
function xxHash32Mixup(crc: cardinal): cardinal;
{$ifdef HASINLINE}inline;{$endif}
const
/// Knuth's magic number for hashing a 32-bit value, using the golden ratio
// - then use the result high bits, i.e. via "shr" not via "and"
// - for instance, mormot.core.log uses it to hash the TThreadID:
// $ hash := cardinal(cardinal(id) * KNUTH_HASH32_MUL) shr (32 - MAXLOGTHREADBITS);
KNUTH_HASH32_MUL = $9E3779B1;
/// Knuth's magic number for hashing a 64-bit value, using the golden ratio
KNUTH_HASH64_MUL = $9E3779B97F4A7C15;
/// Knuth's magic number for hashing a PtrUInt, using the golden ratio
{$ifdef CPU32}
KNUTH_HASHPTR_MUL = KNUTH_HASH32_MUL;
KNUTH_HASHPTR_SHR = 32;
{$else}
KNUTH_HASHPTR_MUL = KNUTH_HASH64_MUL;
KNUTH_HASHPTR_SHR = 64;
{$endif CPU32}
var
/// the 32-bit default hasher used by TDynArrayHashed
// - set to crc32csse42() if SSE4.2 or ARMv8 are available on this CPU,
// or fallback to xxHash32() which is faster than crc32cfast() e.g. on ARM
// - mormot.crypt.core may assign safer and faster AesNiHash32() if available
// - so the hash value may change on another computer or after program restart
DefaultHasher: THasher = xxHash32;
/// the 32-bit hash function used by TRawUtf8Interning
// - set to crc32csse42() if SSE4.2 or ARMv8 are available on this CPU,
// or fallback to xxHash32() which performs better than crc32cfast()
// - mormot.crypt.core may assign safer and faster AesNiHash32() if available
// - so the hash value may change on another computer or after program restart
InterningHasher: THasher = xxHash32;
/// a 64-bit hasher function
// - crc32cTwice() by default, but mormot.crypt.core may assign AesNiHash64()
// - so the hash value may change on another computer or after program restart
DefaultHasher64: THasher64 = crc32cTwice;
/// a 128-bit hasher function
// - crc32c128() by default, but mormot.crypt.core may assign AesNiHash128()
// - so the hash value may change on another computer or after program restart
DefaultHasher128: THasher128 = crc32c128;
/// compute a 32-bit hash of any string using DefaultHasher()
// - so the hash value may change on another computer or after program restart
function DefaultHash(const s: RawByteString): cardinal; overload;
{$ifdef HASINLINE}inline;{$endif}
/// compute a 32-bit hash of any array of bytes using DefaultHasher()
// - so the hash value may change on another computer or after program restart
function DefaultHash(const b: TBytes): cardinal; overload;
{$ifdef HASINLINE}inline;{$endif}
/// compute a 32-bit hash of any string using the CRC32C checksum
// - the returned hash value will be stable on all platforms, and use HW opcodes
// if available on the current CPU
function crc32cHash(const s: RawByteString): cardinal; overload;
{$ifdef HASINLINE}inline;{$endif}
/// compute a 32-bit hash of any array of bytes using the CRC32C checksum
// - the returned hash value will be stable on all platforms, and use HW opcodes
// if available on the current CPU
function crc32cHash(const b: TBytes): cardinal; overload;
{$ifdef HASINLINE}inline;{$endif}
/// combine/reduce a 128-bit hash into a 64-bit hash
// - e.g. from non cryptographic 128-bit hashers with linked lower/higher 64-bit
function Hash128To64(const b: THash128): QWord;
{$ifdef HASINLINE}inline;{$endif}
/// get maximum possible (worse) SynLZ compressed size
function SynLZcompressdestlen(in_len: integer): integer;
{$ifdef HASINLINE}inline;{$endif}
/// get exact uncompressed size from SynLZ-compressed buffer (to reserve memory, e.g.)
function SynLZdecompressdestlen(in_p: PAnsiChar): integer;
/// raw SynLZ compression algorithm implemented in pascal
// - you should rather call SynLZcompress1() which is likely to be much faster
function SynLZcompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
/// raw SynLZ decompression algorithm implemented in pascal
// - you should rather call SynLZdecompress1() which is likely to be much faster
function SynLZdecompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
/// SynLZ decompression algorithm with memory boundaries check
// - this function is slower, but will allow to uncompress only the start
// of the content (e.g. to read some metadata header)
// - it will also check for dst buffer overflow, so will be more secure than
// other functions, which expect the content to be verified (e.g. via CRC)
function SynLZdecompress1partial(src: PAnsiChar; size: integer; dst: PAnsiChar;
maxDst: integer): integer;
/// raw SynLZ compression algorithm
// - includes optimized x86/x64 asm version on Intel/AMD
// - just redirects to SynLZcompress1pas on other CPUs
// - note that SynLZ is not very good at compressing a lot of zeros: it excels
// with somewhat already pre-encoded data like text, JSON or our mormot.core.data
// binary serialization
function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
{$ifndef CPUINTEL} inline; {$endif}
/// raw SynLZ decompression algorithm
// - includes optimized x86/x64 asm version on Intel/AMD
// - just redirects to SynLZcompress1pas on other CPUs
function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
{$ifndef CPUINTEL} inline; {$endif}
/// compress a data content using the SynLZ algorithm
// - as expected by THttpSocket.RegisterCompress
// - will return 'synlz' as ACCEPT-ENCODING: header parameter
// - will store a hash of both compressed and uncompressed stream: if the
// data is corrupted during transmission, will instantly return ''
function CompressSynLZ(var Data: RawByteString; Compress: boolean): RawUtf8;
/// return the Hash32() 32-bit CRC of CompressSynLZ() uncompressed data
// - will first check the CRC of the supplied compressed Data
// - returns 0 if the CRC of the compressed Data is not correct
function CompressSynLZGetHash32(const Data: RawByteString): cardinal;
/// simple Run-Length-Encoding compression of a memory buffer
// - SynLZ is not good with input of a lot of redundant bytes, e.g. chunks of
// zeros: you could pre-process RleCompress/RleUnCompress such data before SynLZ
// - see AlgoRleLZ as such a RLE + SynLZ algorithm
// - returns the number of bytes written to dst, or -1 on dstsize overflow
function RleCompress(src, dst: PByteArray; srcsize, dstsize: PtrUInt): PtrInt;
/// simple Run-Length-Encoding uncompression of a memory buffer
// - SynLZ is not good with input of a lot of redundant bytes, e.g. chunks of
// zeros: you could pre-process RleCompress/RleUnCompress such data before SynLZ
// - see AlgoRleLZ as such a RLE + SynLZ algorithm
function RleUnCompress(src, dst: PByteArray; size: PtrUInt): PtrUInt;
/// partial Run-Length-Encoding uncompression of a memory buffer
function RleUnCompressPartial(src, dst: PByteArray; size, max: PtrUInt): PtrUInt;
/// internal hash table adjustment as called from TDynArrayHasher.HashDelete
// - decrement any integer greater or equal to a deleted value
// - brute force O(n) indexes fix after deletion (much faster than full ReHash)
// - we offer very optimized SSE2 and AVX2 versions on x86_64 - therefore is
// defined in this unit to put this asm code in mormot.core.base.asmx64.inc
procedure DynArrayHashTableAdjust(P: PIntegerArray; deleted: integer; count: PtrInt);
/// DynArrayHashTableAdjust() version for 16-bit HashTable[] - SSE2 asm on x86_64
procedure DynArrayHashTableAdjust16(P: PWordArray; deleted: cardinal; count: PtrInt);
{ ************ Efficient Variant Values Conversion }
type
PVarType = ^TVarType;
const
/// unsigned 64bit integer variant type
// - currently called varUInt64 in Delphi (not defined in older versions),
// and varQWord in FPC
varWord64 = 21;
/// map the Windows VT_INT extended VARENUM, i.e. a 32-bit signed integer
// - also detected and handled by VariantToInteger/VariantToInt64
varOleInt = 22;
/// map the Windows VT_UINT extended VARENUM, i.e. a 32-bit unsigned integer
// - also detected and handled by VariantToInteger/VariantToInt64
varOleUInt = 23;
/// map the Windows VT_LPSTR extended VARENUM, i.e. a PAnsiChar
// - also detected and handled by VariantToUtf8
varOlePAnsiChar = 30;
/// map the Windows VT_LPWSTR extended VARENUM, i.e. a PWideChar
// - also detected and handled by VariantToUtf8
varOlePWideChar = 31;
/// map the Windows VT_FILETIME extended VARENUM, i.e. a 64-bit TFileTime
// - also detected and handled by VariantToDateTime
varOleFileTime = 64;
/// map the Windows VT_CLSID extended VARENUM, i.e. a by-reference PGuid
varOleClsid = 72;
varVariantByRef = varVariant or varByRef;
varStringByRef = varString or varByRef;
varOleStrByRef = varOleStr or varByRef;
/// this variant type will map the current SynUnicode type
// - depending on the compiler version
{$ifdef HASVARUSTRING}
varSynUnicode = varUString;
varUStringByRef = varUString or varByRef;
{$else}
varSynUnicode = varOleStr;
{$endif HASVARUSTRING}
/// this variant type will map the current string type
// - depending on the compiler string definition (UnicodeString or AnsiString)
{$ifdef UNICODE}
varNativeString = varUString;
{$else}
varNativeString = varString;
{$endif UNICODE}
{$ifdef ISDELPHI}
CFirstUserType = $10F;
{$endif ISDELPHI}
/// those TVarData.VType values are meant to be direct values
VTYPE_SIMPLE = [varEmpty..varDate, varBoolean, varShortInt..varWord64,
{$ifdef OSWINDOWS} varOleInt, varOleUInt, varOlePAnsiChar, varOlePWideChar,
varOleFileTime, {$endif OSWINDOWS} varUnknown];
/// bitmask used by our inlined VarClear() to avoid unneeded VarClearProc()
VTYPE_STATIC = $BFE8;
/// a slightly faster alternative to Variants.Null function with TVarData
NullVarData: TVarData = (VType: varNull{%H-});
FalseVarData: TVarData = (VType: varBoolean{%H-});
TrueVarData: TVarData = (VType: varBoolean; VInteger: {%H-}1);
var
/// a slightly faster alternative to Variants.Null function
Null: variant absolute NullVarData;
/// a slightly faster alternative to false constant when assigned to a variant
VarFalse: variant absolute FalseVarData;
/// a slightly faster alternative to true constant when assigned to a variant
VarTrue: variant absolute TrueVarData;
{$ifdef HASINLINE}
/// overloaded function which can be properly inlined to clear a variant
procedure VarClear(var v: variant); inline;
{$endif HASINLINE}
/// overloaded function which can be properly inlined to clear a variant
procedure VarClearAndSetType(var v: variant; vtype: integer);
{$ifdef HASINLINE}inline;{$endif}
/// internal efficient wrapper of VarClear() + set VType=varString and VAny=nil
// - used e.g. by RawUtf8ToVariant() functions
// - could also be used as a faster alternative to Value := ''
procedure ClearVariantForString(var Value: variant);
{$ifdef HASINLINE}inline;{$endif}
/// same as Value := Null, but slightly faster
procedure SetVariantNull(var Value: variant);
{$ifdef HASINLINE}inline;{$endif}
/// convert a raw binary buffer into a variant RawByteString varString
// - you can then use VariantToRawByteString() to retrieve the binary content
procedure RawByteStringToVariant(Data: PByte; DataLen: integer; var Value: variant); overload;
/// convert a RawByteString content into a variant varString
// - you can then use VariantToRawByteString() to retrieve the binary content
procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant); overload;
/// convert back a RawByteString from a variant
// - the supplied variant should have been created via a RawByteStringToVariant()
// function call
procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString);
/// get the root PVarData of a variant, redirecting any varByRef
// - if result^.VPointer=nil, returns varEmpty
function VarDataFromVariant(const Value: variant): PVarData;
{$ifdef HASINLINE}inline;{$endif}
/// same as VarIsEmpty(V) or VarIsNull(V), but faster
// - we also discovered some issues with FPC's Variants unit, so this function
// may be used even in end-user cross-compiler code
function VarIsEmptyOrNull(const V: Variant): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// same as VarIsEmpty(PVariant(V)^) or VarIsNull(PVariant(V)^), but faster
// - we also discovered some issues with FPC's Variants unit, so this function
// may be used even in end-user cross-compiler code
function VarDataIsEmptyOrNull(VarData: pointer): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// same as Dest := TVarData(Source) for simple values
// - will return TRUE for all simple values after varByRef unreference, and
// copying the unreferenced Source value into Dest raw storage
// - will return FALSE for not varByRef values, or complex values (e.g. string)
function SetVariantUnRefSimpleValue(const Source: variant; var Dest: TVarData): boolean;
{$ifdef HASINLINE}inline;{$endif}
/// convert any numerical Variant into a 32-bit integer
// - it will expect true numerical Variant and won't convert any string nor
// floating-pointer Variant, which will return FALSE and won't change the
// Value variable content
function VariantToInteger(const V: Variant; var Value: integer): boolean;
/// convert any numerical Variant into a 64-bit integer
// - it will expect true numerical Variant and won't convert any string nor
// floating-pointer Variant, which will return FALSE and won't change the
// Value variable content
function VariantToInt64(const V: Variant; var Value: Int64): boolean;
/// convert any numerical Variant into a 64-bit integer
// - it will expect true numerical Variant and won't convert any string nor
// floating-pointer Variant, which will return the supplied DefaultValue
function VariantToInt64Def(const V: Variant; DefaultValue: Int64): Int64;
/// convert any numerical Variant into a floating point value
function VariantToDouble(const V: Variant; var Value: double): boolean;
/// convert any numerical Variant into a floating point value
function VariantToDoubleDef(const V: Variant; const default: double = 0): double;
/// convert any numerical Variant into a fixed decimals floating point value
function VariantToCurrency(const V: Variant; var Value: currency): boolean;
/// convert any numerical Variant into a boolean value
// - text content will return true after case-sensitive 'true' comparison
function VariantToBoolean(const V: Variant; var Value: boolean): boolean;
/// convert any numerical Variant into an integer
// - it will expect true numerical Variant and won't convert any string nor
// floating-pointer Variant, which will return the supplied DefaultValue
function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer; overload;
/// convert an UTF-8 encoded text buffer into a variant RawUtf8 varString
procedure RawUtf8ToVariant(Txt: PUtf8Char; TxtLen: integer; var Value: variant); overload;
/// convert an UTF-8 encoded string into a variant RawUtf8 varString
procedure RawUtf8ToVariant(const Txt: RawUtf8; var Value: variant); overload;
/// convert an UTF-8 encoded string into a variant RawUtf8 varString
function RawUtf8ToVariant(const Txt: RawUtf8): variant; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a Variant varString value into RawUtf8 encoded String
// - works as the exact reverse of RawUtf8ToVariant() function
// - non varString variants (e.g. UnicodeString, WideString, numbers, empty and
// null) will be returned as ''
// - use VariantToUtf8() instead if you need to convert numbers or other strings
// - use VariantSaveJson() instead if you need a conversion to JSON with
// custom parameters
procedure VariantStringToUtf8(const V: Variant; var result: RawUtf8); overload;
/// convert Variant string values into RawUtf8 encoded String
// - works as the exact reverse of RawUtf8ToVariant() function
// - non varString variants (e.g. UnicodeString, WideString, numbers, empty and
// null) will be returned as ''
function VariantStringToUtf8(const V: Variant): RawUtf8; overload;
var
/// efficient finalization of successive variant items from a (dynamic) array
// - this unit will include a basic version calling VarClear()
// - mormot.core.variants will assign a more efficient implementation
VariantClearSeveral: procedure(V: PVarData; n: integer);
/// compare two variant/TVarData values, with or without case sensitivity
// - this unit registers the basic VariantCompSimple() case-sensitive comparer
// - mormot.core.variants will assign the much better FastVarDataComp()
// - called e.g. by SortDynArrayVariant/SortDynArrayVariantI functions
SortDynArrayVariantComp: function(
const A, B: TVarData; caseInsensitive: boolean): integer;
/// basic default case-sensitive variant comparison function
// - try as VariantToInt64/VariantToDouble, then RTL VarCompareValue()
function VariantCompSimple(const A, B: variant): integer;
{ ************ Sorting/Comparison Functions }
type
/// function prototype to be used for TDynArray Sort and Find method
// - common functions exist for base types: see e.g. SortDynArrayBoolean,
// SortDynArrayByte, SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal,
// SortDynArrayInt64, SortDynArrayQWord, SordDynArraySingle, SortDynArrayDouble,
// SortDynArrayAnsiString, SortDynArrayAnsiStringI, SortDynArrayUnicodeString,
// SortDynArrayUnicodeStringI, SortDynArrayString, SortDynArrayStringI
// - any custom type (even records) can be compared then sort by defining
// such a custom function
// - must return 0 if A=B, -1 if A<B, 1 if A>B
// - simple types are compared within this unit (with proper optimized asm
// if possible), whereas more complex types are implemented in other units -
// e.g. SortDynArrayVariant/SortDynArrayVariantI are in mormot.core.variants
// and SortDynArrayPUtf8CharI/SortDynArrayStringI in mormot.core.text
TDynArraySortCompare = function(const A, B): integer;
/// the recognized operators for comparison functions results match
TCompareOperator = (
coEqualTo,
coNotEqualTo,
coLessThan,
coLessThanOrEqualTo,
coGreaterThan,
coGreaterThanOrEqualTo);
/// fast search if a comparison function result (<0,0,>0) match an operator
function SortMatch(CompareResult: integer; CompareOperator: TCompareOperator): boolean;
{$ifdef HASINLINE} inline; {$endif}
/// compare two "array of boolean" elements
function SortDynArrayBoolean(const A, B): integer;
/// compare two "array of shortint" elements
function SortDynArrayShortint(const A, B): integer;
/// compare two "array of byte" elements
function SortDynArrayByte(const A, B): integer;
/// compare two "array of smallint" elements
function SortDynArraySmallint(const A, B): integer;
/// compare two "array of word" elements
function SortDynArrayWord(const A, B): integer;
/// compare two "array of integer" elements
function SortDynArrayInteger(const A, B): integer;
/// compare two "array of cardinal" elements
function SortDynArrayCardinal(const A, B): integer;
/// compare two "array of Int64" or "array of Currency" elements
function SortDynArrayInt64(const A, B): integer;
/// compare two "array of QWord" elements
// - note that QWord(A)>QWord(B) is wrong on older versions of Delphi, so you
// should better use this function or CompareQWord() to properly compare two
// QWord values over CPUX86
function SortDynArrayQWord(const A, B): integer;
/// compare two "array of THash128" elements
function SortDynArray128(const A, B): integer;
/// compare two "array of THash256" elements
function SortDynArray256(const A, B): integer;
/// compare two "array of THash512" elements
function SortDynArray512(const A, B): integer;
/// compare two "array of TObject/pointer" elements
function SortDynArrayPointer(const A, B): integer;
/// compare two "array of single" elements
function SortDynArraySingle(const A, B): integer;
/// compare two "array of double" elements
function SortDynArrayDouble(const A, B): integer;
/// compare two "array of extended" elements
function SortDynArrayExtended(const A, B): integer;
/// compare two "array of AnsiString" elements, with case sensitivity
// - on Intel/AMD will use efficient i386/x86_64 assembly using length
// - on other CPU, will redirect to inlined StrComp() using #0 trailing char
function SortDynArrayAnsiString(const A, B): integer;
/// compare two "array of RawByteString" elements, with case sensitivity
// - can't use StrComp() or similar functions since RawByteString may contain #0
// - on Intel/AMD, the more efficient SortDynArrayAnsiString asm is used instead
{$ifdef CPUINTEL}
var SortDynArrayRawByteString: TDynArraySortCompare = SortDynArrayAnsiString;
{$else}
function SortDynArrayRawByteString(const A, B): integer;
{$endif CPUINTEL}
/// compare two "array of PUtf8Char/PAnsiChar" elements, with case sensitivity
function SortDynArrayPUtf8Char(const A, B): integer;
/// compare two "array of WideString/UnicodeString" elements, with case sensitivity
function SortDynArrayUnicodeString(const A, B): integer;
/// compare two "array of RTL string" elements, with case sensitivity
// - the expected string type is the RTL string
function SortDynArrayString(const A, B): integer;
/// compare two "array of shortstring" elements, with case sensitivity
function SortDynArrayShortString(const A, B): integer;
/// compare two "array of variant" elements, with case sensitivity
// - just a wrapper around SortDynArrayVariantComp(A,B,false)
function SortDynArrayVariant(const A, B): integer;
/// compare two "array of variant" elements, with no case sensitivity
// - just a wrapper around SortDynArrayVariantComp(A,B,true)
function SortDynArrayVariantI(const A, B): integer;
/// low-level inlined function for exchanging two pointers
// - used e.g. during sorting process
procedure ExchgPointer(n1, n2: PPointer);
{$ifdef HASINLINE}inline;{$endif}
/// low-level inlined function for exchanging two sets of pointers
// - used e.g. during sorting process
procedure ExchgPointers(n1, n2: PPointer; count: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
/// low-level inlined function for exchanging two variants
// - used e.g. during sorting process
procedure ExchgVariant(v1, v2: PPtrIntArray);
{$ifdef CPU64} inline;{$endif}
/// low-level inlined function for exchanging two memory buffers
// - used e.g. during sorting process
procedure Exchg(P1, P2: PAnsiChar; count: PtrInt);
{$ifdef HASINLINE}inline;{$endif}
{ ************ Some Convenient TStream descendants and File access functions }
type
/// a dynamic array of TStream instances
TStreamDynArray = array of TStream;
{$M+}
/// TStream with a protected fPosition field
TStreamWithPosition = class(TStream)
protected
fPosition: Int64;
{$ifdef FPC}
function GetPosition: Int64; override;
{$endif FPC}
public
/// change the current Read/Write position, within current GetSize
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
/// call the 64-bit Seek() overload
function Seek(Offset: Longint; Origin: Word): Longint; override;
end;
{$M-}
/// TStream with two protected fPosition/fSize fields
TStreamWithPositionAndSize = class(TStreamWithPosition)
protected
fSize: Int64;
function GetSize: Int64; override;
end;
/// TStream using a RawByteString as internal storage
// - default TStringStream uses UTF-16 WideChars since Delphi 2009, so it is
// not compatible with previous versions or FPC, and it makes more sense to
// work with RawByteString/RawUtf8 in our UTF-8 oriented framework
// - just like TStringStream, is designed for appending data, not modifying
// in-place, as requested e.g. by TJsonWriter or TBufferWriter classes
TRawByteStringStream = class(TStreamWithPosition)
protected
fDataString: RawByteString;
function GetSize: Int64; override;
procedure SetSize(NewSize: Longint); override;
public
/// initialize the storage, optionally with some RawByteString content
// - to be used for Read() from this memory buffer
constructor Create(const aString: RawByteString); overload;
/// read some bytes from the internal storage
// - returns the number of bytes filled into Buffer (<=Count)
function Read(var Buffer; Count: Longint): Longint; override;
/// append some data to the buffer
// - will resize the buffer, i.e. will replace the end of the string from
// the current position with the supplied data
function Write(const Buffer; Count: Longint): Longint; override;
/// retrieve the stored content from a given position, as UTF-8 text
// - warning: may directly return DataString and reset its value to ''
procedure GetAsText(StartPos, Len: PtrInt; var Text: RawUtf8);
/// reset the internal DataString content and the current position
procedure Clear;
{$ifdef HASINLINE}inline;{$endif}
/// direct low-level access to the internal RawByteString storage
property DataString: RawByteString
read fDataString write fDataString;
end;
/// TStream pointing to some existing in-memory data, for instance UTF-8 text
// - warning: there is no local copy of the supplied content: the
// source data must be available during all the TSynMemoryStream usage
TSynMemoryStream = class(TCustomMemoryStream)
public
/// create a TStream with the supplied text data
// - warning: there is no local copy of the supplied content: the aText
// variable must be available during all the TSynMemoryStream usage:
// don't release aText before calling TSynMemoryStream.Free
// - aText can be on any AnsiString format, e.g. RawUtf8 or RawByteString
constructor Create(const aText: RawByteString); overload;
/// create a TStream with the supplied data buffer
// - warning: there is no local copy of the supplied content: the
// Data/DataLen buffer must be available during all the TSynMemoryStream usage:
// don't release the source Data before calling TSynMemoryStream.Free
constructor Create(Data: pointer; DataLen: PtrInt); overload;
/// this TStream is read-only: calling this method will raise an exception
function Write(const Buffer; Count: Longint): Longint; override;
end;
/// raise a EStreamError exception - e.g. from TSynMemoryStream.Write
function RaiseStreamError(Caller: TObject; const Context: shortstring): PtrInt;
{ ************ Raw Shared Constants / Types Definitions }
{ some types defined here, but implemented in mormot.core.datetime or
mormot.core.log, so that they may be used and identified by
mormot.core.rtti or mormot.core.os }
type
/// the available logging events, as handled by mormot.core.log
// - defined in mormot.core.base so that it may be used by the core units,
// even if mormot.core.log is not explicitely linked
// - limited to 32 items, to efficiently fit in a 32-bit set
// - sllInfo will log general information events
// - sllDebug will log detailed debugging information
// - sllTrace will log low-level step by step debugging information
// - sllWarning will log unexpected values (not an error)
// - sllError will log errors
// - sllEnter will log every method start
// - sllLeave will log every method exit
// - sllLastError will log the GetLastError OS message
// - sllException will log all exception raised - available since Windows XP
// - sllExceptionOS will log all OS low-level exceptions (EDivByZero,
// ERangeError, EAccessViolation...)
// - sllMemory will log memory statistics (in MB units)
// - sllStackTrace will log caller's stack trace (it's by default part of
// TSynLogFamily.LevelStackTrace like sllError, sllException, sllExceptionOS,
// sllLastError and sllFail)
// - sllFail was defined for TSynTestsLogged.Failed method, and can be used
// to log some customer-side assertions (may be notifications, not errors)
// - sllSQL is dedicated to trace the SQL statements
// - sllCache should be used to trace the internal caching mechanism
// - sllResult could trace the SQL results, JSON encoded
// - sllDB is dedicated to trace low-level database engine features
// - sllHTTP could be used to trace HTTP process
// - sllClient/sllServer could be used to trace some Client or Server process
// - sllServiceCall/sllServiceReturn to trace some remote service or library
// - sllUserAuth to trace user authentication (e.g. for individual requests)
// - sllCustom* items can be used for any purpose
// - sllNewRun will be written when a process opens a rotated log
// - sllDDDError will log any DDD-related low-level error information
// - sllDDDInfo will log any DDD-related low-level debugging information
// - sllMonitoring will log the statistics information (if available),
// or may be used for real-time chat among connected people to ToolsAdmin
TSynLogLevel = (
sllNone, sllInfo, sllDebug, sllTrace, sllWarning, sllError,
sllEnter, sllLeave,
sllLastError, sllException, sllExceptionOS, sllMemory, sllStackTrace,
sllFail, sllSQL, sllCache, sllResult, sllDB, sllHTTP, sllClient, sllServer,
sllServiceCall, sllServiceReturn, sllUserAuth,
sllCustom1, sllCustom2, sllCustom3, sllCustom4, sllNewRun,
sllDDDError, sllDDDInfo, sllMonitoring);
/// used to define a set of logging level abilities
// - i.e. a combination of none or several logging event
// - e.g. use LOG_VERBOSE constant to log all events, or LOG_STACKTRACE
// to log all errors and exceptions
TSynLogLevels = set of TSynLogLevel;
/// a dynamic array of logging event levels
TSynLogLevelDynArray = array of TSynLogLevel;
/// callback definition used to abstractly log some events
// - defined as TMethod to avoid dependency with the mormot.core.log unit
// - match class procedure TSynLog.DoLog
// - used e.g. by global variables like WindowsServiceLog in mormot.core.os
// or TCrtSocket.OnLog in mormot.net.sock
TSynLogProc = procedure(Level: TSynLogLevel; const Fmt: RawUtf8;
const Args: array of const; Instance: TObject = nil) of object;
{$ifndef PUREMORMOT2}
TSynLogInfo = TSynLogLevel;
TSynLogInfos = TSynLogLevels;
TSynLogInfoDynArray = TSynLogLevelDynArray;
{$endif PUREMORMOT2}
type
/// fast bit-encoded date and time value
// - see TTimeLog helper functions and types in mormot.core.datetime
// - faster than Iso-8601 text and TDateTime, e.g. can be used as published
// property field in mORMot's TOrm (see also TModTime and TCreateTime)
// - use internally for computation an abstract "year" of 16 months of 32 days
// of 32 hours of 64 minutes of 64 seconds - same as Iso8601ToTimeLog()
// - use TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow functions, or
// type-cast any TTimeLog value with the TTimeLogBits memory structure for
// direct access to its bit-oriented content (or via PTimeLogBits pointer)
// - since TTimeLog type is bit-oriented, you can't just add or substract two
// TTimeLog values when doing date/time computation: use a TDateTime temporary
// conversion in such case:
// ! aTimestamp := TimeLogFromDateTime(IncDay(TimeLogToDateTime(aTimestamp)));
TTimeLog = type Int64;
/// dynamic array of TTimeLog
// - recognized e.g. by TDynArray JSON serialization
TTimeLogDynArray = array of TTimeLog;
/// a type alias, which will be serialized as ISO-8601 with milliseconds
// - i.e. 'YYYY-MM-DD hh:mm:ss.sss' or 'YYYYMMDD hhmmss.sss' format
TDateTimeMS = type TDateTime;
/// a dynamic array of TDateTimeMS values
TDateTimeMSDynArray = array of TDateTimeMS;
/// pointer to a dynamic array of TDateTimeMS values
PDateTimeMSDynArray = ^TDateTimeMSDynArray;
/// a 64-bit identifier, as used for our ORM primary key, i.e. TOrm.ID
// - also maps the SQLite3 64-bit RowID definition
TID = type Int64;
/// a pointer to TOrm.ID, i.e. our ORM primary key
PID = ^TID;
/// used to store a dynamic array of ORM primary keys, i.e. TOrm.ID
TIDDynArray = array of TID;
/// pointer to a dynamic array of ORM primary keys, i.e. TOrm.ID
PIDDynArray = ^TIDDynArray;
/// timestamp stored as second-based Unix Time
// - see Unix Time helper functions and types in mormot.core.datetime
// - i.e. the number of seconds since 1970-01-01 00:00:00 UTC
// - is stored as 64-bit value, so that it won't be affected by the
// "Year 2038" overflow issue
// - see TUnixMSTime for a millisecond resolution Unix Timestamp
// - use UnixTimeToDateTime/DateTimeToUnixTime functions to convert it to/from
// a regular TDateTime
// - use UnixTimeUtc to return the current timestamp, using fast OS API call
// - also one of the encodings supported by SQLite3 date/time functions
TUnixTime = type Int64;
/// pointer to a timestamp stored as second-based Unix Time
PUnixTime = ^TUnixTime;
/// dynamic array of timestamps stored as second-based Unix Time
TUnixTimeDynArray = array of TUnixTime;
/// timestamp stored as millisecond-based Unix Time
// - see Unix Time helper functions and types in mormot.core.datetime
// - i.e. the number of milliseconds since 1970-01-01 00:00:00 UTC
// - see TUnixTime for a second resolution Unix Timestamp
// - use UnixMSTimeToDateTime/DateTimeToUnixMSTime functions to convert it
// to/from a regular TDateTime
// - also one of the JavaScript date encodings
TUnixMSTime = type Int64;
/// pointer to a timestamp stored as millisecond-based Unix Time
PUnixMSTime = ^TUnixMSTime;
/// dynamic array of timestamps stored as millisecond-based Unix Time
TUnixMSTimeDynArray = array of TUnixMSTime;
const
/// may be used to log as Trace or Warning event, depending on an Error: boolean
LOG_TRACEWARNING: array[boolean] of TSynLogLevel = (
sllTrace,
sllWarning);
implementation
{$ifdef ISDELPHI20062007}
uses
Windows; // circumvent unexpected warning about inlining (WTF!)
{$endif ISDELPHI20062007}
{$ifdef FPC}
// globally disable some FPC paranoid warnings - rely on x86_64 as reference
{$WARN 4056 off : Conversion between ordinals and pointers is not portable }
{$endif FPC}
{ ************ Common Types Used for Compatibility Between Compilers and CPU }
procedure VarClearAndSetType(var v: variant; vtype: integer);
var
p: PInteger; // more efficient generated asm with an explicit temp variable
begin
p := @v;
{$if defined(OSBSDDARWIN) and defined(ARM3264)}
if PVarData(p)^.VType and VTYPE_STATIC <> 0 then // just like in Variants.pas
{$else}
if p^ and VTYPE_STATIC <> 0 then
{$ifend}
VarClearProc(PVarData(p)^);
p^ := vtype;
end;
{$ifdef HASINLINE}
procedure VarClear(var v: variant); // defined here for proper inlining
var
p: PInteger; // more efficient generated asm with an explicit temp variable
begin
p := @v;
{$if defined(OSBSDDARWIN) and defined(ARM3264)}
if PVarData(p)^.VType and VTYPE_STATIC = 0 then // just like in Variants.pas
{$else}
if p^ and VTYPE_STATIC = 0 then
{$ifend}
p^ := 0
else
VarClearProc(PVarData(p)^);
end;
{$endif HASINLINE}
{$ifdef CPUARM}
function ToByte(value: cardinal): cardinal;
begin
result := value and $ff;
end;
{$endif CPUARM}
{$ifdef CPUX86} // directly use the x87 FPU stack
procedure CurrencyToDouble(const c: currency; out d: double);
begin
d := c;
end;
procedure CurrencyToDouble(c: PCurrency; out d: double);
begin
d := c^;
end;
function CurrencyToDouble(c: PCurrency): double;
begin
result := c^;
end;
procedure DoubleToCurrency(const d: double; out c: currency);
begin
c := d;
end;
procedure DoubleToCurrency(const d: double; c: PCurrency);
begin
c^ := d;
end;
function DoubleToCurrency(const d: double): currency;
begin
result := d;
end;
{$else} // efficient inlined 64-bit integer version
procedure CurrencyToDouble(const c: currency; out d: double);
begin
unaligned(d{%H-}) := PInt64(@c)^ / CURR_RES;
end;
procedure CurrencyToDouble(c: PCurrency; out d: double);
begin
unaligned(d{%H-}) := PInt64(c)^ / CURR_RES;
end;
function CurrencyToDouble(c: PCurrency): double;
begin
result := PInt64(c)^ / CURR_RES;
end;
procedure DoubleToCurrency(const d: double; out c: currency);
begin
PInt64(@c)^ := trunc(d * CURR_RES);
end;
procedure DoubleToCurrency(const d: double; c: PCurrency);
begin
PInt64(c)^ := trunc(d * CURR_RES);
end;
function DoubleToCurrency(const d: double): currency;
begin
result := trunc(d * CURR_RES);
end;
{$endif CPUX86}
procedure CurrencyToInt64(c: PCurrency; var i: Int64);
begin
i := PInt64(c)^ div CURR_RES;
end;
procedure CurrencyToVariant(const c: currency; var v: variant);
begin
VarClearAndSetType(v, varCurrency);
PVarData(@v).VCurrency := c;
end;
function SimpleRoundTo2Digits(Value: Currency): Currency;
begin
SimpleRoundTo2DigitsCurr64(PInt64(@Value)^);
result := Value;
end;
procedure SimpleRoundTo2DigitsCurr64(var Value: Int64);
var
Spare: PtrInt;
begin
Spare := Value mod 100;
if Spare <> 0 then
if Spare > 50 then
{%H-}inc(Value, 100 - Spare)
else if Spare < -50 then
{%H-}dec(Value, 100 + Spare)
else
dec(Value, Spare);
end;
function TwoDigits(const d: double): TShort31;
var
v: Int64;
m, L: PtrInt;
tmp: array[0..23] of AnsiChar;
P: PAnsiChar;
begin
v := trunc(d * CURR_RES);
m := v mod 100;
if m <> 0 then
if m > 50 then
{%H-}inc(v, 100 - m)
else if m < -50 then
{%H-}dec(v, 100 + m)
else
dec(v, m);
P := {%H-}StrInt64(@tmp[23], v);
L := @tmp[22] - P;
m := PWord(@tmp[L - 2])^;
if m = ord('0') or ord('0') shl 8 then
// '300' -> '3'
dec(L, 3)
else
begin
// '301' -> '3.01'
PWord(@tmp[L - 1])^ := m;
tmp[L - 2] := '.';
end;
SetString(result, P, L);
end;
function TruncTo2Digits(Value: Currency): Currency;
var
V64: Int64 absolute Value; // to avoid any floating-point precision issues
begin
dec(V64, V64 mod 100);
result := Value;
end;
procedure TruncTo2DigitsCurr64(var Value: Int64);
begin
dec(Value, Value mod 100);
end;
function TruncTo2Digits64(Value: Int64): Int64;
begin
result := Value - Value mod 100;
end;
procedure Int64ToCurrency(const i: Int64; out c: currency);
begin
PInt64(@c)^ := i * CURR_RES;
end;
procedure Int64ToCurrency(const i: Int64; c: PCurrency);
begin
PInt64(c)^ := i * CURR_RES;
end;
function IsEqualGuid({$ifdef FPC_HAS_CONSTREF}constref{$else}const{$endif}
guid1, guid2: TGuid): boolean;
begin
result := (PHash128Rec(@guid1).L = PHash128Rec(@guid2).L) and
(PHash128Rec(@guid1).H = PHash128Rec(@guid2).H);
end;
function IsEqualGuid(guid1, guid2: PGuid): boolean;
begin
result := (PHash128Rec(guid1).L = PHash128Rec(guid2).L) and
(PHash128Rec(guid1).H = PHash128Rec(guid2).H);
end;
function IsEqualGuidArray(const guid: TGuid; const guids: array of TGuid): integer;
begin
result := Hash128Index(@guids[0], length(guids), @guid);
end;
function IsNullGuid({$ifdef FPC_HAS_CONSTREF}constref{$else}const{$endif} guid: TGuid): boolean;
var
a: TPtrIntArray absolute Guid;
begin
result := (a[0] = 0) and
(a[1] = 0) {$ifdef CPU32} and
(a[2] = 0) and
(a[3] = 0) {$endif CPU32};
end;
function AddGuid(var guids: TGuidDynArray; const guid: TGuid; NoDuplicates: boolean): integer;
begin
if NoDuplicates then
begin
result := Hash128Index(pointer(guids), length(guids), @guid);
if result>=0 then
exit;
end;
result := length(guids);
SetLength(guids, result + 1);
guids[result] := guid;
end;
procedure FillZero(var result: TGuid);
var
d: TInt64Array absolute result;
begin
d[0] := 0;
d[1] := 0;
end;
function RandomGuid: TGuid;
begin
RandomGuid(result);
end;
procedure RandomGuid(out result: TGuid);
begin // see https://datatracker.ietf.org/doc/html/rfc4122#section-4.4
RandomBytes(@result, SizeOf(TGuid));
result.D3 := (result.D3 and $0FFF) + $4000; // version bits 12-15 = 4 (random)
result.D4[0] := byte(result.D4[0] and $3F) + $80; // reserved bits 6-7 = 1
end;
function NextGrow(capacity: integer): integer;
begin
// algorithm similar to TFPList.Expand for the increasing ranges
result := capacity;
if result < 8 then
inc(result, 4) // faster for smaller capacity (called often)
else if result <= 128 then
inc(result, 16)
else if result < 8 shl 20 then
inc(result, result shr 2)
else if result < 128 shl 20 then
inc(result, result shr 3)
else
inc(result, 16 shl 20);
end;
{$ifndef FPC_ASMX64}
procedure FastAssignNew(var d; s: pointer);
var
sr: PStrRec; // local copy to use register
begin
sr := Pointer(d);
Pointer(d) := s;
if sr = nil then
exit;
dec(sr);
if (sr^.refcnt >= 0) and
StrCntDecFree(sr^.refcnt) then
FreeMem(sr);
end;
procedure FastAssignNewNotVoid(var d; s: pointer);
var
sr: PStrRec; // local copy to use register
begin
sr := Pointer(d);
Pointer(d) := s;
dec(sr);
if (sr^.refcnt >= 0) and
StrCntDecFree(sr^.refcnt) then
FreeMem(sr);
end;
{$endif FPC_ASMX64}
function FastNewString(len, codepage: PtrInt): PAnsiChar;
var
P: PStrRec;
begin
result := nil;
if len > 0 then
begin
{$ifdef FPC}
P := GetMem(len + (_STRRECSIZE + 4));
result := PAnsiChar(P) + _STRRECSIZE;
{$else}
GetMem(result, len + (_STRRECSIZE + 4));
P := pointer(result);
inc(PStrRec(result));
{$endif FPC}
{$ifdef HASCODEPAGE} // also set elemSize := 1
{$ifdef FPC}
P^.codePageElemSize := codepage + (1 shl 16);
{$else}
PCardinal(@P^.codePage)^ := codepage + (1 shl 16);
{$endif FPC}
{$endif HASCODEPAGE}
P^.refCnt := 1;
P^.length := len;
PCardinal(PAnsiChar(P) + len + _STRRECSIZE)^ := 0; // ends with four #0
end;
end;
{$ifdef HASCODEPAGE}
procedure EnsureRawUtf8(var s: RawByteString);
begin
if s <> '' then
with PStrRec(PAnsiChar(pointer(s)) - _STRRECSIZE)^ do
if CodePage <> CP_UTF8 then
if refCnt <> 1 then
FastSetString(RawUtf8(s), pointer(s), length) // make copy
else
CodePage := CP_UTF8; // just replace in-place
end;
procedure EnsureRawUtf8(var s: RawUtf8);
begin
EnsureRawUtf8(RawByteString(s));
end;
procedure FakeCodePage(var s: RawByteString; cp: cardinal);
var
p: PAnsiChar;
begin
p := pointer(s);
if p <> nil then
PStrRec(p - _STRRECSIZE)^.CodePage := cp;
end;
function GetCodePage(const s: RawByteString): cardinal;
begin
result := PStrRec(PAnsiChar(pointer(s)) - _STRRECSIZE)^.CodePage;
end;
procedure FastAssignUtf8(var dest: RawUtf8; var src: RawByteString);
begin
FakeCodePage(RawByteString(src), CP_UTF8);
FastAssignNew(dest, pointer(src));
pointer(src) := nil; // was assigned with no ref-counting involved
end;
{$else} // do nothing on Delphi 7-2007
procedure FakeCodePage(var s: RawByteString; cp: cardinal);
begin
end;
procedure EnsureRawUtf8(var s: RawByteString);
begin
end;
procedure EnsureRawUtf8(var s: RawUtf8);
begin
end;
procedure FastAssignUtf8(var dest: RawUtf8; var src: RawByteString);
begin
FastAssignNew(dest, pointer(src));
pointer(src) := nil; // was assigned with no ref-counting involved
end;
{$endif HASCODEPAGE}
procedure FakeLength(var s: RawUtf8; len: PtrInt);
var
p: PAnsiChar; // faster with a temp variable
begin
p := pointer(s);
p[len] := #0;
PStrLen(p - _STRLEN)^ := len; // in-place SetLength()
end;
procedure FakeLength(var s: RawUtf8; endChar: PUtf8Char);
var
p: PAnsiChar;
begin
p := pointer(s);
endChar^ := #0;
PStrLen(p - _STRLEN)^ := endChar - p;
end;
procedure FakeLength(var s: RawByteString; len: PtrInt);
var
p: PAnsiChar;
begin
p := pointer(s);
p[len] := #0;
PStrLen(p - _STRLEN)^ := len; // in-place SetLength()
end;
procedure FakeSetLength(var s: RawUtf8; len: PtrInt);
begin
if len <= 0 then
FastAssignNew(s)
else
FakeLength(s, len);
end;
procedure FakeSetLength(var s: RawByteString; len: PtrInt); overload;
begin
if len <= 0 then
FastAssignNew(s)
else
FakeLength(s, len);
end;
procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt);
var
r: pointer;
begin
r := FastNewString(len, codepage);
if (p <> nil) and
(r <> nil) then
MoveFast(p^, r^, len);
if pointer(s) = nil then
pointer(s) := r
else
FastAssignNewNotVoid(s, r);
end;
procedure FastSetString(var s: RawUtf8; p: pointer; len: PtrInt);
var
r: pointer;
begin
r := FastNewString(len, CP_UTF8); // FPC will do proper constant propagation
if (p <> nil) and
(r <> nil) then
MoveFast(p^, r^, len);
if pointer(s) = nil then
pointer(s) := r
else
FastAssignNewNotVoid(s, r);
end;
procedure FastSetString(var s: RawUtf8; len: PtrInt);
var
r: pointer;
begin
r := FastNewString(len, CP_UTF8);
if pointer(s) = nil then
pointer(s) := r
else
FastAssignNewNotVoid(s, r);
end;
procedure FastSetRawByteString(var s: RawByteString; p: pointer; len: PtrInt);
var
r: pointer;
begin
r := FastNewString(len, CP_RAWBYTESTRING); // FPC does constant propagation
if (p <> nil) and
(r <> nil) then
MoveFast(p^, r^, len);
if pointer(s) = nil then
pointer(s) := r
else
FastAssignNewNotVoid(s, r);
end;
procedure FastNewRawByteString(var s: RawByteString; len: PtrInt);
var
r: pointer;
begin
r := FastNewString(len, CP_RAWBYTESTRING);
if pointer(s) = nil then
pointer(s) := r
else
FastAssignNewNotVoid(s, r);
end;
procedure GetMemAligned(var holder: RawByteString; fillwith: pointer;
len: PtrUInt; out aligned: pointer; alignment: PtrUInt);
begin
dec(alignment); // expected to be a power of two
FastNewRawByteString(holder, len + alignment);
aligned := pointer(holder);
while PtrUInt(aligned) and alignment <> 0 do
inc(PByte(aligned));
if fillwith <> nil then
MoveFast(fillwith^, aligned^, len);
end;
// CompareMemSmall/MoveByOne defined now for proper inlining below
// warning: Delphi has troubles inlining goto/label
function CompareMemSmall(P1, P2: Pointer; Length: PtrInt): boolean;
var
c: AnsiChar;
begin
result := false;
inc(PtrUInt(P1), PtrUInt(Length));
inc(PtrUInt(P2), PtrUInt(Length));
Length := -Length;
if Length <> 0 then
repeat
c := PAnsiChar(P1)[Length];
if c <> PAnsiChar(P2)[Length] then
exit;
inc(Length);
until Length = 0;
result := true;
end;
procedure MoveByOne(Source, Dest: Pointer; Count: PtrUInt);
var
c: AnsiChar; // better code generation on FPC
begin
inc(PtrUInt(Source), Count);
inc(PtrUInt(Dest), Count);
PtrInt(Count) := -PtrInt(Count);
repeat
c := PAnsiChar(Source)[Count];
PAnsiChar(Dest)[Count] := c;
inc(Count);
until Count = 0;
end;
function UniqueRawUtf8(var u: RawUtf8): pointer;
begin
{$ifdef FPC}
UniqueString(u); // @u[1] won't call UniqueString() under FPC :(
{$endif FPC}
result := @u[1];
end;
function ShortStringToAnsi7String(const source: ShortString): RawByteString;
begin
FastSetString(RawUtf8(result), @source[1], ord(source[0]));
end;
procedure ShortStringToAnsi7String(const source: ShortString; var result: RawUtf8);
begin
FastSetString(result, @source[1], ord(source[0]));
end;
procedure Ansi7StringToShortString(const source: RawUtf8; var result: ShortString);
begin
SetString(result, PAnsiChar(pointer(source)), length(source));
end;
procedure AppendShort(const src: ShortString; var dest: ShortString);
var
len: PtrInt;
begin
len := ord(src[0]);
if (len = 0) or
(len + ord(dest[0]) > 255) then
exit;
MoveFast(src[1], dest[ord(dest[0]) + 1], len);
inc(dest[0], len);
end;
procedure AppendShortChar(chr: AnsiChar; var dest: ShortString);
begin
if dest[0] = #255 then
exit;
inc(dest[0]);
dest[ord(dest[0])] := chr;
end;
const
HexChars: array[0..15] of AnsiChar = '0123456789ABCDEF';
HexCharsLower: array[0..15] of AnsiChar = '0123456789abcdef';
procedure AppendShortByteHex(value: byte; var dest: ShortString);
var
len: PtrInt;
begin
len := ord(dest[0]);
if len >= 254 then
exit;
dest[len + 1] := HexChars[value shr 4];
inc(len, 2);
value := value and $0f;
dest[len] := HexChars[value];
dest[0] := AnsiChar(len);
end;
procedure AppendShortTemp24(value, temp: PAnsiChar; dest: PAnsiChar);
{$ifdef HASINLINE} inline; {$endif}
var
valuelen, destlen, newlen: PtrInt;
begin
valuelen := temp - value;
destlen := ord(dest[0]);
newlen := valuelen + destlen;
if newlen > 255 then
exit;
dest[0] := AnsiChar(newlen);
MoveFast(value^, dest[destlen + 1], valuelen);
end;
procedure AppendShortCardinal(value: cardinal; var dest: ShortString);
var
tmp: array[0..23] of AnsiChar;
begin
AppendShortTemp24(StrUInt32(@tmp[23], value), @tmp[23], @dest);
end;
procedure AppendShortInt64(value: Int64; var dest: ShortString);
var
tmp: array[0..23] of AnsiChar;
begin
AppendShortTemp24(StrInt64(@tmp[23], value), @tmp[23], @dest);
end;
procedure AppendShortBuffer(buf: PAnsiChar; len: integer; var dest: ShortString);
begin
if len < 0 then
len := StrLen(buf);
if (len = 0) or
(len + ord(dest[0]) > 255) then
exit;
MoveFast(buf^, dest[ord(dest[0]) + 1], len);
inc(dest[0], len);
end;
procedure AppendShortAnsi7String(const buf: RawByteString; var dest: ShortString);
begin
if buf <> '' then
AppendShortBuffer(pointer(buf), PStrLen(PtrUInt(buf) - _STRLEN)^, dest);
end;
function ClassNameShort(C: TClass): PShortString;
// new TObject.ClassName is UnicodeString (since Delphi 2009) -> inline code
// with vmtClassName = UTF-8 encoded text stored in a ShortString = -44
begin
result := PPointer(PtrInt(PtrUInt(C)) + vmtClassName)^;
end;
function ClassNameShort(Instance: TObject): PShortString;
begin
if Instance = nil then
result := @NULCHAR // avoid GPF
else
result := PPointer(PPtrInt(Instance)^ + vmtClassName)^;
end;
procedure ClassToText(C: TClass; var result: RawUtf8);
var
P: PShortString;
begin
if C = nil then
result := '' // avoid GPF
else
begin
P := PPointer(PtrInt(PtrUInt(C)) + vmtClassName)^;
FastSetString(result, @P^[1], ord(P^[0]));
end;
end;
function ToText(C: TClass): RawUtf8;
begin
ClassToText(C, result);
end;
function GetClassParent(C: TClass): TClass;
begin
result := PPointer(PtrInt(PtrUInt(C)) + vmtParent)^;
{$ifndef HASDIRECTTYPEINFO} // e.g. for Delphi and newer FPC
if result <> nil then
result := PPointer(result)^;
{$endif HASDIRECTTYPEINFO}
end;
function PropNameEquals(P1, P2: PShortString): boolean;
var
P1P2Len: PtrInt;
label
zero;
begin
P1P2Len := ord(P1^[0]);
if P1P2Len <> ord(P2^[0]) then
goto zero;
inc(PByte(P1));
inc(PByte(P2));
P1P2Len := PtrInt(@PByteArray(P1)[P1P2Len - SizeOf(cardinal)]); // 32-bit end
if P1P2Len >= PtrInt(PtrUInt(P1)) then
repeat // case-insensitive compare 4 bytes per loop
if (PCardinal(P1)^ xor PCardinal(P2)^) and $dfdfdfdf <> 0 then
goto zero;
inc(PCardinal(P1));
inc(PCardinal(P2));
until P1P2Len < PtrInt(PtrUInt(P1));
inc(PCardinal(P1P2Len));
dec(PtrUInt(P2), PtrUInt(P1));
if PtrInt(PtrUInt(P1)) < P1P2Len then
repeat
if (PByte(P1)^ xor PByteArray(P2)[PtrUInt(P1)]) and $df <> 0 then
goto zero;
inc(PByte(P1));
until PtrInt(PtrUInt(P1)) >= P1P2Len;
result := true;
exit;
zero:
result := false;
end;
function PropNameEquals(const P1, P2: RawUtf8): boolean;
var
P1P2Len, _1, _2: PtrInt;
label
zero;
begin
P1P2Len := length(P1);
if P1P2Len <> length(P2) then
goto zero;
_1 := PtrUInt(P1);
_2 := PtrUInt(P2);
P1P2Len := PtrInt(@PByteArray(_1)[P1P2Len - SizeOf(cardinal)]); // 32-bit end
if P1P2Len >= _1 then
repeat // case-insensitive compare 4 bytes per loop
if (PCardinal(_1)^ xor PCardinal(_2)^) and $dfdfdfdf <> 0 then
goto zero;
inc(PCardinal(_1));
inc(PCardinal(_2));
until P1P2Len < _1;
inc(PCardinal(P1P2Len));
dec(_2, _1);
if _1 < P1P2Len then
repeat
if (PByte(_1)^ xor PByteArray(_2)[PtrUInt(_1)]) and $df <> 0 then
goto zero;
inc(PByte(_1));
until _1 >= P1P2Len;
result := true;
exit;
zero:
result := false;
end;
{$ifdef HASINLINE} // defined here for proper inlining
function CompareMemFixed(P1, P2: Pointer; Length: PtrInt): boolean;
label
zero;
begin
// cut-down version of our pure pascal CompareMem() function
{$ifndef CPUX86}
result := false;
{$endif CPUX86}
Length := PtrInt(@PAnsiChar(P1)[Length - SizeOf(PtrInt)]);
if Length >= PtrInt(PtrUInt(P1)) then
repeat // compare one PtrInt per loop
if PPtrInt(P1)^ <> PPtrInt(P2)^ then
goto zero;
inc(PPtrInt(P1));
inc(PPtrInt(P2));
until Length < PtrInt(PtrUInt(P1));
inc(Length, SizeOf(PtrInt));
dec(PtrUInt(P2), PtrUInt(P1));
if PtrInt(PtrUInt(P1)) < Length then
repeat
if PByte(P1)^ <> PByteArray(P2)[PtrUInt(P1)] then
goto zero;
inc(PByte(P1));
until PtrInt(PtrUInt(P1)) >= Length;
result := true;
exit;
zero:
{$ifdef CPUX86}
result := false;
{$endif CPUX86}
end;
{$endif HASINLINE}
function FindNonVoidRawUtf8(n: PPointerArray; name: pointer; len: TStrLen;
count: PtrInt): PtrInt;
var
p: PUtf8Char;
begin
// FPC does proper inlining in this loop
result := 0;
repeat
p := n[result]; // all VName[]<>'' so p=n^<>nil
if (PStrLen(p - _STRLEN)^ = len) and
(p^ = PAnsiChar(name)^) and
((len = 1) or
CompareMemFixed(p + 1, PAnsiChar(name) + 1, len - 1)) then
exit;
inc(result);
dec(count);
until count = 0;
result := -1;
end;
function FindNonVoidRawUtf8I(n: PPointerArray; name: pointer; len: TStrLen;
count: PtrInt): PtrInt;
var
p1, p2, l: PUtf8Char;
label
no;
begin
result := 0;
p2 := name;
repeat
// inlined IdemPropNameUSameLenNotNull(p, name, len)
p1 := n[result]; // all VName[]<>'' so p1<>nil
if (PStrLen(p1 - _STRLEN)^ = len) and
((ord(p1^) xor ord(p2^)) and $df = 0) then
begin
if len = 1 then
exit;
inc(p1);
inc(p2);
l := @p1[len - (SizeOf(cardinal) + 1)];
dec(p2, PtrUInt(p1));
while PtrUInt(l) >= PtrUInt(p1) do
// compare 4 Bytes per loop
if (PCardinal(p1)^ xor PCardinal(@p2[PtrUInt(p1)])^) and $dfdfdfdf <> 0 then
goto no
else
inc(PCardinal(p1));
inc(PCardinal(l));
while PtrUInt(p1) < PtrUInt(l) do
// remaining bytes
if (ord(p1^) xor ord(p2[PtrUInt(p1)])) and $df <> 0 then
goto no
else
inc(PByte(p1));
exit; // match found
no: p2 := name;
end;
inc(result);
dec(count);
until count = 0;
result := -1;
end;
function FindPropName(Values: PRawUtf8Array; const Value: RawUtf8;
ValuesCount: PtrInt): PtrInt;
begin
if (Values <> nil) and
(ValuesCount > 0) and
(Value <> '') then
result := FindNonVoidRawUtf8I(pointer(Values), pointer(Value),
PStrLen(PAnsiChar(pointer(Value)) - _STRLEN)^, ValuesCount)
else
result := -1;
end;
function FindPropName(const Names: array of RawUtf8; const Name: RawUtf8): integer;
begin
result := high(Names);
if result >= 0 then
result := FindPropName(@Names[0], Name, result + 1);
end;
function DateTimeToIsoString(dt: TDateTime): string;
begin
// avoid to link mormot.core.datetime
DateTimeToString(result, 'yyyy-mm-dd hh:nn:ss', dt);
end;
procedure ToHumanHex(var result: RawUtf8; bin: PByteArray; len: PtrInt);
var
P: PAnsiChar;
i, c: PtrInt;
tab: PAnsichar;
begin
if len <= 0 then
begin
result := '';
exit;
end;
FastSetString(result, (len * 3) - 1);
dec(len);
tab := @HexCharsLower;
P := pointer(result);
i := 0;
repeat
c := bin[i];
P[0] := tab[c shr 4];
c := c and 15;
P[1] := tab[c];
if i = len then
break;
P[2] := ':'; // to please (most) human limited hexadecimal capabilities
inc(P, 3);
inc(i);
until false;
end;
procedure ToHumanHexReverse(var result: RawUtf8; bin: PByteArray; len: PtrInt);
var
P: PAnsiChar;
i, c: PtrInt;
tab: PAnsichar;
begin
if len <= 0 then
begin
result := '';
exit;
end;
FastSetString(result, (len * 3) - 1);
tab := @HexCharsLower;
P := pointer(result);
i := len;
repeat
dec(i);
c := bin[i];
P[0] := tab[c shr 4];
c := c and 15;
P[1] := tab[c];
if i = 0 then
break;
P[2] := ':';
inc(P, 3);
until false;
end;
{ ************ Numbers (floats and integers) Low-level Definitions }
function GetInteger(P: PUtf8Char): PtrInt;
var
c: byte;
minus: boolean;
begin
result := 0;
if P = nil then
exit;
c := byte(P^);
repeat
if c = 0 then
exit;
if c > ord(' ') then
break;
inc(P);
c := byte(P^);
until false;
if c = ord('-') then
begin
minus := true;
repeat
inc(P);
c := byte(P^);
until c <> ord(' ');
end
else
begin
minus := false;
if c = ord('+') then
repeat
inc(P);
c := byte(P^);
until c <> ord(' ');
end;
dec(c, 48);
if c > 9 then
exit;
result := c;
repeat
inc(P);
c := byte(P^);
dec(c, 48);
if c > 9 then
break;
result := result * 10 + PtrInt(c);
until false;
if minus then
result := -result;
end;
function GetInteger(P, PEnd: PUtf8Char): PtrInt;
var
c: byte;
minus: boolean;
begin
result := 0;
if (P = nil) or
(P >= PEnd) then
exit;
c := byte(P^);
repeat
if c = 0 then
exit;
if c > ord(' ') then
break;
inc(P);
if P = PEnd then
exit;
c := byte(P^);
until false;
if c = ord('-') then
begin
minus := true;
repeat
inc(P);
if P = PEnd then
exit;
c := byte(P^);
until c <> ord(' ');
end
else
begin
minus := false;
if c = ord('+') then
repeat
inc(P);
if P = PEnd then
exit;
c := byte(P^);
until c <> ord(' ');
end;
dec(c, 48);
if c > 9 then
exit;
result := c;
repeat
inc(P);
if P = PEnd then
break;
c := byte(P^);
dec(c, 48);
if c > 9 then
break;
result := result * 10 + PtrInt(c);
until false;
if minus then
result := -result;
end;
function GetInteger(P: PUtf8Char; var err: integer): PtrInt;
var
c: byte;
minus: boolean;
begin
result := 0;
err := 1; // don't return the exact index, just 1 as error flag
if P = nil then
exit;
c := byte(P^);
repeat
if c = 0 then
exit;
if c > ord(' ') then
break;
inc(P);
c := byte(P^);
until false;
if c = ord('-') then
begin
minus := true;
repeat
inc(P);
c := byte(P^);
until c <> ord(' ');
end
else
begin
minus := false;
if c = ord('+') then
repeat
inc(P);
c := byte(P^);
until c <> ord(' ');
end;
dec(c, 48);
if c > 9 then
exit;
result := c;
repeat
inc(P);
c := byte(P^);
dec(c, 48);
if c <= 9 then
result := result * 10 + PtrInt(c)
else if c <> 256 - 48 then
exit
else
break;
until false;
err := 0; // success
if minus then
result := -result;
end;
function GetIntegerDef(P: PUtf8Char; Default: PtrInt): PtrInt;
var
err: integer;
begin
result := GetInteger(P, err);
if err <> 0 then
result := Default;
end;
function GetBoolean(P: PUtf8Char): boolean;
begin
result := (P <> nil) and
(PInteger(P)^ <> FALSE_LOW) and
((PInteger(P)^ = TRUE_LOW) or
((PInteger(P)^ and $ffff) <> ord('0')));
end;
function GetBoolean(const value: RawUtf8): boolean;
begin
result := GetBoolean(pointer(value));
end;
function GetTrue(P: PUtf8Char): integer;
begin
result := PInteger(P)^ and $dfdfdfdf;
if (result = ord('T') + ord('R') shl 8 + ord('U') shl 16 + ord('E') shl 24) or
(result = ord('Y') + ord('E') shl 8 + ord('S') shl 16) then
result := 1
else
result := 0;
end;
function GetInt64Bool(P: PUtf8Char; out V: Int64): boolean;
var
err, c: integer;
begin
result := P <> nil;
if not result then
exit;
V := GetInt64(P, err);
if err = 0 then
exit;
c := PInteger(P)^ and $dfdfdfdf;
if (c = ord('F') + ord('A') shl 8 + ord('L') shl 16 + ord('S') shl 24) or
(c and $ffffff = ord('N') + ord('O') shl 8) then
V := 0
else if (c = ord('T') + ord('R') shl 8 + ord('U') shl 16 + ord('E') shl 24) or
(c = ord('Y') + ord('E') shl 8 + ord('S') shl 16) then
V := 1
else
result := false;
end;
function GetCardinalDef(P: PUtf8Char; Default: PtrUInt): PtrUInt;
var
c: byte;
begin
result := Default;
if P = nil then
exit;
c := byte(P^);
repeat
if c = 0 then
exit;
if c > ord(' ') then
break;
inc(P);
c := byte(P^);
until false;
dec(c, 48);
if c > 9 then
exit;
result := c;
repeat
inc(P);
c := byte(P^) - 48;
if c > 9 then
break;
result := result * 10 + PtrUInt(c);
until false;
end;
function GetCardinal(P: PUtf8Char): PtrUInt;
var
c: byte;
begin
result := 0;
if P = nil then
exit;
c := byte(P^);
repeat
if c = 0 then
exit;
if c > ord(' ') then
break;
inc(P);
c := byte(P^);
until false;
dec(c, 48);
if c > 9 then
exit;
result := c;
repeat
inc(P);
c := byte(P^);
dec(c, 48);
if c > 9 then
break;
result := result * 10 + PtrUInt(c);
until false;
end;
function GetCardinal(P, PEnd: PUtf8Char): PtrUInt;
var
c: byte;
begin
result := 0;
if (P = nil) or
(P >= PEnd) then
exit;
c := byte(P^);
repeat
if c = 0 then
exit;
if c > ord(' ') then
break;
inc(P);
if P = PEnd then
exit;
c := byte(P^);
until false;
dec(c, 48);
if c > 9 then
exit;
result := c;
repeat
inc(P);
if P = PEnd then
break;
c := byte(P^);
dec(c, 48);
if c > 9 then
break;
result := result * 10 + PtrUInt(c);
until false;
end;
function GetCardinalW(P: PWideChar): PtrUInt;
var
c: PtrUInt;
begin
result := 0;
if P = nil then
exit;
c := ord(P^);
repeat
if c = 0 then
exit;
if c > ord(' ') then
break;
inc(P);
c := ord(P^);
until false;
dec(c, 48);
if c > 9 then
exit;
result := c;
repeat
inc(P);
c := ord(P^);
dec(c, 48);
if c > 9 then
break;
result := result * 10 + c;
until false;
end;
function GetInt64Def(P: PUtf8Char; const Default: Int64): Int64;
var
err: integer;
begin
result := GetInt64(P, err);
if err > 0 then
result := Default;
end;
{$ifdef CPU64}
// PtrInt/PtrUInt are already Int64/QWord
procedure SetInt64(P: PUtf8Char; var result: Int64);
begin
result := GetInteger(P);
end;
procedure SetQWord(P: PUtf8Char; var result: QWord);
begin
result := GetCardinal(P);
end;
procedure SetQWord(P, PEnd: PUtf8Char; var result: QWord);
begin
result := GetCardinal(P, PEnd);
end;
function GetInt64(P: PUtf8Char): Int64;
begin
result := GetInteger(P);
end;
function GetInt64(P: PUtf8Char; var err: integer): Int64;
begin
result := GetInteger(P, err);
end;
function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar;
begin
result := StrUInt32(P, val); // StrUInt32 converts PtrUInt=QWord on 64-bit CPU
end;
function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar;
begin
result := StrInt32(P, val); // StrInt32 converts PtrInt=Int64 on 64-bit CPU
end;
function GetQWord(P: PUtf8Char; var err: integer): QWord;
var
c: PtrUInt;
begin
err := 1; // error
result := 0;
if P = nil then
exit;
while (P^ <= ' ') and
(P^ <> #0) do
inc(P);
c := byte(P^) - 48;
if c > 9 then
exit;
result := c;
inc(P);
repeat
c := byte(P^);
if c = 0 then
break;
dec(c, 48);
if c > 9 then
exit;
result := result * 10 + c;
inc(P);
until false;
err := 0; // success
end;
{$else}
// 32-bit dedicated code - use integer/cardinal as much as possible
procedure SetInt64(P: PUtf8Char; var result: Int64);
var
c: cardinal;
minus: boolean;
begin
result := 0;
if P = nil then
exit;
while (P^ <= ' ') and
(P^ <> #0) do
inc(P);
if P^ = '-' then
begin
minus := true;
repeat
inc(P)
until P^ <> ' ';
end
else
begin
minus := false;
if P^ = '+' then
repeat
inc(P)
until P^ <> ' ';
end;
c := byte(P^) - 48;
if c > 9 then
exit;
PCardinal(@result)^ := c;
inc(P);
repeat // fast 32-bit loop
c := byte(P^) - 48;
if c > 9 then
break
else
PCardinal(@result)^ := PCardinal(@result)^ * 10 + c;
inc(P);
if PCardinal(@result)^ >= high(cardinal) div 10 then
begin
repeat // 64-bit loop
c := byte(P^) - 48;
if c > 9 then
break;
result := result shl 3 + result + result; // fast result := result*10
inc(result, c);
inc(P);
until false;
break;
end;
until false;
if minus then
result := -result;
end;
procedure SetQWord(P: PUtf8Char; var result: QWord);
var
c: cardinal;
begin
result := 0;
if P = nil then
exit;
while (P^ <= ' ') and
(P^ <> #0) do
inc(P);
if P^ = '+' then
repeat
inc(P)
until P^ <> ' ';
c := byte(P^) - 48;
if c > 9 then
exit;
PCardinal(@result)^ := c;
inc(P);
repeat // fast 32-bit loop
c := byte(P^) - 48;
if c > 9 then
break
else
PCardinal(@result)^ := PCardinal(@result)^ * 10 + c;
inc(P);
if PCardinal(@result)^ >= high(cardinal) div 10 then
begin
repeat // 64-bit loop
c := byte(P^) - 48;
if c > 9 then
break;
result := result shl 3 + result + result; // fast result := result*10
inc(result, c);
inc(P);
until false;
break;
end;
until false;
end;
procedure SetQWord(P, PEnd: PUtf8Char; var result: QWord);
var
c: cardinal;
begin
result := 0;
if (P = nil) or
(P >= PEnd) then
exit;
while P^ <= ' ' do
if P = PEnd then
exit
else
inc(P);
if P^ = '+' then
repeat
inc(P);
if P = PEnd then
exit;
until P^ <> ' ';
c := byte(P^) - 48;
if c > 9 then
exit;
PCardinal(@result)^ := c;
inc(P);
repeat // fast 32-bit loop
if P = PEnd then
break;
c := byte(P^) - 48;
if c > 9 then
break
else
PCardinal(@result)^ := PCardinal(@result)^ * 10 + c;
inc(P);
if PCardinal(@result)^ >= high(cardinal) div 10 then
begin
repeat // 64-bit loop
if P = PEnd then
exit;
c := byte(P^) - 48;
if c > 9 then
break;
result := result shl 3 + result + result; // fast result := result*10
inc(result, c);
inc(P);
until false;
break;
end;
until false;
end;
function GetInt64(P: PUtf8Char): Int64;
begin
SetInt64(P, result);
end;
function GetInt64(P: PUtf8Char; var err: integer): Int64;
var
c: cardinal;
minus: boolean;
begin
err := 0;
result := 0;
if P = nil then
exit;
while (P^ <= ' ') and
(P^ <> #0) do
inc(P);
if P^ = '-' then
begin
minus := true;
repeat
inc(P)
until P^ <> ' ';
end
else
begin
minus := false;
if P^ = '+' then
repeat
inc(P)
until P^ <> ' ';
end;
inc(err);
c := byte(P^) - 48;
if c > 9 then
exit;
PCardinal(@result)^ := c;
inc(P);
repeat // fast 32-bit loop
c := byte(P^);
if c <> 0 then
begin
dec(c, 48);
inc(err);
if c > 9 then
exit;
PCardinal(@result)^ := PCardinal(@result)^ * 10 + c;
inc(P);
if PCardinal(@result)^ >= high(cardinal) div 10 then
begin
repeat // 64-bit loop
c := byte(P^);
if c = 0 then
begin
err := 0; // conversion success without error
break;
end;
dec(c, 48);
inc(err);
if c > 9 then
exit
else
{$ifdef CPU32DELPHI}
result := result shl 3 + result + result;
{$else}
result := result * 10;
{$endif CPU32DELPHI}
inc(result, c);
if result < 0 then
exit; // overflow (>$7FFFFFFFFFFFFFFF)
inc(P);
until false;
break;
end;
end
else
begin
err := 0; // reached P^=#0 -> conversion success without error
break;
end;
until false;
if minus then
result := -result;
end;
function GetQWord(P: PUtf8Char; var err: integer): QWord;
var
c: PtrUInt;
begin
err := 1; // error
result := 0;
if P = nil then
exit;
while (P^ <= ' ') and
(P^ <> #0) do
inc(P);
c := byte(P^) - 48;
if c > 9 then
exit;
PByte(@result)^ := c;
inc(P);
repeat // fast 32-bit loop
c := byte(P^);
if c <> 0 then
begin
dec(c, 48);
inc(err);
if c > 9 then
exit;
PCardinal(@result)^ := PCardinal(@result)^ * 10 + c;
inc(P);
if PCardinal(@result)^ >= high(cardinal) div 10 then
begin
repeat // 64-bit loop
c := byte(P^);
if c = 0 then
begin
err := 0; // conversion success without error
break;
end;
dec(c, 48);
inc(err);
if c > 9 then
exit
else
{$ifdef CPU32DELPHI}
result := result shl 3 + result + result;
{$else}
result := result * 10;
{$endif CPU32DELPHI}
inc(result, c);
inc(P);
until false;
break;
end;
end
else
begin
err := 0; // reached P^=#0 -> conversion success without error
break;
end;
until false;
end;
function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar;
var
c, c100: QWord;
{$ifdef CPUX86NOTPIC}
tab: TWordArray absolute TwoDigitLookupW;
{$else}
tab: PWordArray;
{$endif CPUX86NOTPIC}
begin
if PCardinalArray(@val)^[1] = 0 then
P := StrUInt32(P, PCardinal(@val)^)
else
begin
{$ifndef CPUX86NOTPIC}
tab := @TwoDigitLookupW;
{$endif CPUX86NOTPIC}
c := val;
repeat
{$ifdef CPUX86}
asm // by-passing the RTL is a good idea here
push ebx
mov edx, dword ptr [c + 4]
mov eax, dword ptr [c]
mov ebx, 100
mov ecx, eax
mov eax, edx
xor edx, edx
div ebx
mov dword ptr [c100 + 4], eax
xchg eax, ecx
div ebx
mov dword ptr [c100], eax
imul ebx, ecx
mov ecx, 100
mul ecx
add edx, ebx
pop ebx
sub dword ptr [c + 4], edx
sbb dword ptr [c], eax
end;
{$else}
c100 := c div 100; // one div by two digits
dec(c, c100 * 100); // fast c := c mod 100
{$endif CPUX86}
dec(P, 2);
PWord(P)^ := tab[c];
c := c100;
if (PCardinalArray(@c)^[1] = 0) then
begin
if PCardinal(@c)^ <> 0 then
P := StrUInt32(P, PCardinal(@c)^);
break;
end;
until false;
end;
result := P;
end;
function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar;
begin
if val < 0 then
begin
P := StrUInt64(P, -val) - 1;
P^ := '-';
end
else
P := StrUInt64(P, val);
result := P;
end;
{$endif CPU64}
function GetExtended(P: PUtf8Char): TSynExtended;
var
err: integer;
begin
result := GetExtended(P, err);
if err <> 0 then
result := 0;
end;
function HugePower10Pos(exponent: PtrInt; pow10: PPow10): TSynExtended;
begin
result := pow10[(exponent and not 31) shr 5 + 34] * pow10[exponent and 31];
end;
function HugePower10Neg(exponent: PtrInt; pow10: PPow10): TSynExtended;
begin
exponent := -exponent;
result := pow10[(exponent and not 31) shr 5 + 45] / pow10[exponent and 31];
end;
{$ifndef CPU32DELPHI}
function GetExtended(P: PUtf8Char; out err: integer): TSynExtended;
var
remdigit: integer;
frac, exp: PtrInt;
c: AnsiChar;
flags: set of (fNeg, fNegExp, fValid);
v64: Int64; // allows 64-bit resolution for the digits (match 80-bit extended)
label
e;
begin
byte(flags) := 0;
v64 := 0;
frac := 0;
if P = nil then
goto e; // will return 0 but err=1
c := P^;
if c = ' ' then
repeat
inc(P);
c := P^;
until c <> ' '; // trailing spaces
if c = '+' then
begin
inc(P);
c := P^;
end
else if c = '-' then
begin
inc(P);
c := P^;
include(flags, fNeg);
end;
remdigit := 19; // max Int64 resolution
repeat
inc(P);
if (c >= '0') and
(c <= '9') then
begin
dec(remdigit);
if remdigit >= 0 then // over-required digits are just ignored
begin
dec(c, ord('0'));
{$ifdef CPU64}
v64 := v64 * 10;
{$else}
v64 := v64 shl 3 + v64 + v64;
{$endif CPU64}
inc(v64, byte(c));
c := P^;
include(flags, fValid);
if frac <> 0 then
dec(frac); // digits after '.'
continue;
end;
if frac >= 0 then
inc(frac); // handle #############00000
c := P^;
continue;
end;
if c <> '.' then
break;
if frac > 0 then
goto e; // will return partial value but err=1
dec(frac);
c := P^;
until false;
if frac < 0 then
inc(frac); // adjust digits after '.'
if (c = 'E') or
(c = 'e') then
begin
exp := 0;
exclude(flags, fValid);
c := P^;
if c = '+' then
inc(P)
else if c = '-' then
begin
inc(P);
include(flags, fNegExp);
end;
repeat
c := P^;
inc(P);
if (c < '0') or
(c > '9') then
break;
dec(c, ord('0'));
exp := (exp * 10) + byte(c);
include(flags, fValid);
until false;
if fNegExp in flags then
dec(frac, exp)
else
inc(frac, exp);
if (frac <= -324) or
(frac >= 308) then
begin
frac := 0;
goto e; // limit to 5.0 x 10^-324 .. 1.7 x 10^308 double range
end;
end;
if (fValid in flags) and
(c = #0) then
err := 0
else
e: err := 1; // return the (partial) value even if not ended with #0
exp := PtrUInt(@POW10);
if frac >= -31 then
if frac <= 31 then
result := PPow10(exp)[frac] // -31 .. + 31
else
result := HugePower10Pos(frac, PPow10(exp)) // +32 ..
else
result := HugePower10Neg(frac, PPow10(exp)); // .. -32
if fNeg in flags then
result := result * PPow10(exp)[33]; // * -1
result := result * v64;
end;
{$endif CPU32DELPHI}
function Utf8ToInteger(const value: RawUtf8; Default: PtrInt): PtrInt;
var
err: integer;
begin
result := GetInteger(pointer(value), err);
if err <> 0 then
result := Default;
end;
function Utf8ToInteger(const value: RawUtf8; min, max, default: PtrInt): PtrInt;
var
err: integer;
begin
result := GetInteger(pointer(value), err);
if (err <> 0) or
(result < min) or
(result > max) then
result := default;
end;
function ToInteger(const text: RawUtf8; out value: integer): boolean;
var
v, err: integer;
begin
v := GetInteger(pointer(text), err);
result := err = 0;
if result then
value := v;
end;
function ToCardinal(const text: RawUtf8; out value: cardinal; minimal: cardinal): boolean;
var
v: cardinal;
begin
v := GetCardinalDef(pointer(text), cardinal(-1));
result := (v <> cardinal(-1)) and
(v >= minimal);
if result then
value := v;
end;
function ToInt64(const text: RawUtf8; out value: Int64): boolean;
var
err: integer;
v: Int64;
begin
v := GetInt64(pointer(text), err);
result := err = 0;
if result then
value := v;
end;
function ToDouble(const text: RawUtf8; out value: double): boolean;
var
err: integer;
v: double;
begin
v := GetExtended(pointer(text), err);
result := err = 0;
if result then
value := v;
end;
function Utf8ToInt64(const text: RawUtf8; const default: Int64): Int64;
var
err: integer;
begin
result := GetInt64(pointer(text), err);
if err <> 0 then
result := default;
end;
{ ************ integer arrays manipulation }
function IsZero(const Values: TIntegerDynArray): boolean;
var
i: PtrInt;
begin
result := false;
for i := 0 to length(Values) - 1 do
if Values[i] <> 0 then
exit;
result := true;
end;
function IsZero(const Values: TInt64DynArray): boolean;
var
i: PtrInt;
begin
result := false;
for i := 0 to length(Values) - 1 do
if Values[i] <> 0 then
exit;
result := true;
end;
procedure FillZero(var Values: TIntegerDynArray);
begin
FillCharFast(Values[0], length(Values) * SizeOf(integer), 0);
end;
procedure FillZero(var Values: TInt64DynArray);
begin
FillCharFast(Values[0], length(Values) * SizeOf(Int64), 0);
end;
function CompareInteger(const A, B: integer): integer;
begin
result := ord(A > B) - ord(A < B);
end;
function CompareCardinal(const A, B: cardinal): integer;
begin
result := ord(A > B) - ord(A < B);
end;
function ComparePtrInt(const A, B: PtrInt): integer;
begin
result := ord(A > B) - ord(A < B);
end;
function ComparePointer(const A, B: pointer): integer;
begin
result := ord(PtrUInt(A) > PtrUInt(B)) - ord(PtrUInt(A) < PtrUInt(B));
end;
{$ifdef FPC_OR_UNICODE} // recent compilers are able to generate correct code
function CompareInt64(const A, B: Int64): integer;
begin
result := ord(A > B) - ord(A < B);
end;
function CompareQword(const A, B: QWord): integer;
begin
result := ord(A > B) - ord(A < B);
end;
{$else}
function CompareInt64(const A, B: Int64): integer;
begin
// Delphi x86 compiler is not efficient at compiling Int64 comparisons
result := SortDynArrayInt64(A, B);
end;
function CompareQword(const A, B: QWord): integer;
begin
// Delphi x86 compiler is not efficient, and oldest even incorrect
result := SortDynArrayQWord(A, B);
end;
{$endif FPC_OR_UNICODE}
function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean;
begin
if P <> nil then
begin
result := true;
Count := PtrUInt(@P[Count - 4]);
repeat
if PtrUInt(P) > PtrUInt(Count) then
break;
if (P^[0] = Value) or
(P^[1] = Value) or
(P^[2] = Value) or
(P^[3] = Value) then
exit;
P := @P[4];
until false;
inc(Count, 4 * SizeOf(Value));
repeat
if PtrUInt(P) >= PtrUInt(Count) then
break;
if P^[0] = Value then
exit;
P := @P[1];
until false;
end;
result := false;
end;
function Int64Scan(P: PInt64Array; Count: PtrInt; const Value: Int64): PInt64;
begin
result := nil;
if P = nil then
exit;
Count := PtrUInt(@P[Count - 4]);
repeat
if PtrUInt(P) > PtrUInt(Count) then
break;
if P^[0] <> Value then
if P^[1] <> Value then
if P^[2] <> Value then
if P^[3] <> Value then
begin
P := @P[4];
continue;
end
else
result := @P[3]
else
result := @P[2]
else
result := @P[1]
else
result := pointer(P);
exit;
until false;
inc(Count, 4 * SizeOf(Value));
result := pointer(P);
repeat
if PtrUInt(result) >= PtrUInt(Count) then
break;
if result^ = Value then
exit;
inc(result);
until false;
result := nil;
end;
function Int64ScanIndex(P: PInt64Array; Count: PtrInt; const Value: Int64): PtrInt;
begin
result := PtrUInt(Int64Scan(P, Count, Value));
if result = 0 then
dec(result)
else
begin
dec(result, PtrUInt(P));
result := result shr 3;
end;
end;
function QWordScanIndex(P: PQWordArray; Count: PtrInt; const Value: QWord): PtrInt;
begin
result := Int64ScanIndex(pointer(P), Count, Value); // this is the very same code
end;
{$ifdef CPU64}
// PtrInt = Int64 and PtrUInt = QWord
function PtrUIntScan(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): pointer;
begin
result := Int64Scan(pointer(P), Count, Value);
end;
function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean;
begin
result := Int64ScanExists(pointer(P), Count, Value);
end;
function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt;
begin
result := Int64ScanIndex(pointer(P), Count, Value);
end;
procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt);
begin
QuickSortInt64(PInt64Array(P), L, R);
end;
procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt);
begin
QuickSortInt64(PInt64Array(P), L, R);
end;
function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt;
begin
result := FastFindInt64Sorted(PInt64Array(P), R, Value);
end;
function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: pointer): PtrInt;
begin
result := FastFindInt64Sorted(PInt64Array(P), R, Int64(Value));
end;
{$else}
// PtrInt = integer and PtrUInt = cardinal
function PtrUIntScan(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): pointer;
begin
result := IntegerScan(pointer(P), Count, Value);
end;
function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean;
begin
result := IntegerScanExists(pointer(P), Count, Value);
end;
function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt;
begin
result := IntegerScanIndex(pointer(P), Count, Value);
end;
procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt);
begin
QuickSortInteger(PIntegerArray(P), L, R);
end;
procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt);
begin
QuickSortInteger(PIntegerArray(P), L, R);
end;
function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt;
begin
result := FastFindIntegerSorted(PIntegerArray(P), R, Value);
end;
function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: pointer): PtrInt;
begin
result := FastFindIntegerSorted(PIntegerArray(P), R, integer(Value));
end;
{$endif CPU64}
procedure DynArrayFakeLength(arr: pointer; len: TDALen);
begin
PDALen(PAnsiChar(arr) - _DALEN)^ := len - _DAOFF;
end;
{$ifdef FPC} // some FPC-specific low-level code due to diverse compiler or RTL
function TDynArrayRec.GetLength: TDALen;
begin
result := high + 1;
end;
procedure TDynArrayRec.SetLength(len: TDALen);
begin
high := len - 1;
end;
procedure Div100(Y: cardinal; var res: TDiv100Rec); // Delphi=asm, FPC=inlined
var
Y100: cardinal;
begin
Y100 := Y div 100; // FPC will use fast reciprocal
res.D := Y100;
res.M := Y {%H-}- Y100 * 100; // avoid div twice
end;
{$endif FPC}
function AddInteger(var Values: TIntegerDynArray; Value: integer; NoDuplicates: boolean): boolean;
var
n: PtrInt;
begin
n := Length(Values);
if NoDuplicates and
IntegerScanExists(pointer(Values), n, Value) then
begin
result := false;
exit;
end;
SetLength(Values, n + 1);
Values[n] := Value;
result := true
end;
procedure AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; Value: integer);
begin
if ValuesCount = Length(Values) then
SetLength(Values, NextGrow(ValuesCount));
Values[ValuesCount] := Value;
inc(ValuesCount);
end;
function AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Value: integer; NoDuplicates: boolean): boolean;
begin
if NoDuplicates and
IntegerScanExists(pointer(Values), ValuesCount, Value) then
begin
result := false;
exit;
end;
if ValuesCount = Length(Values) then
SetLength(Values, NextGrow(ValuesCount));
Values[ValuesCount] := Value;
inc(ValuesCount);
result := true;
end;
function AddInteger(var Values: TIntegerDynArray; const Another: TIntegerDynArray): PtrInt;
var
v, a: PtrInt;
begin
v := Length(Values);
a := Length(Another);
if a > 0 then
begin
SetLength(Values, v + a);
MoveFast(Another[0], Values[v], a * SizeOf(integer));
end;
result := v + a;
end;
function AddWord(var Values: TWordDynArray; var ValuesCount: integer; Value: Word): PtrInt;
begin
result := ValuesCount;
if result = Length(Values) then
SetLength(Values, NextGrow(result));
Values[result] := Value;
inc(ValuesCount);
end;
function AddInt64(var Values: TInt64DynArray; var ValuesCount: integer; Value: Int64): PtrInt;
begin
result := ValuesCount;
if result = Length(Values) then
SetLength(Values, NextGrow(result));
Values[result] := Value;
inc(ValuesCount);
end;
function AddInt64(var Values: TInt64DynArray; Value: Int64): PtrInt;
begin
result := Length(Values);
SetLength(Values, result + 1);
Values[result] := Value;
end;
function AddInt64(var Values: TInt64DynArray; const Another: TInt64DynArray): PtrInt;
var
v, a: PtrInt;
begin
v := Length(Values);
a := Length(Another);
if a > 0 then
begin
SetLength(Values, v + a);
MoveFast(Another[0], Values[v], a * SizeOf(Int64));
end;
result := v + a;
end;
function AddPtrUInt(var Values: TPtrUIntDynArray;
var ValuesCount: integer; Value: PtrUInt): PtrInt;
begin
result := ValuesCount;
if result = Length(Values) then
SetLength(Values, NextGrow(result));
Values[result] := Value;
inc(ValuesCount);
end;
procedure AddInt64Sorted(var Values: TInt64DynArray; Value: Int64);
var
last: integer;
begin
last := high(Values);
if FastFindInt64Sorted(pointer(Values), last, Value) >= 0 then
exit; // found
inc(last);
SetLength(Values, last + 1);
Values[last] := Value;
QuickSortInt64(pointer(Values), 0, last);
end;
function AddInt64Once(var Values: TInt64DynArray; Value: Int64): PtrInt;
begin
result := Int64ScanIndex(pointer(Values), Length(Values), Value);
if result < 0 then
result := AddInt64(Values, Value);
end;
procedure MakeUniqueArray(old: PDynArrayRec; ItemSizeShl: TDALen);
var
new: PDynArrayRec;
n: PtrInt;
begin
dec(old);
dec(old^.refCnt);
n := (old^.length shl ItemSizeShl) + SizeOf(new^);
new := AllocMem(n);
MoveFast(old^, new^, n); // copy header + all ordinal values
new^.refCnt := 1;
end;
procedure DeleteWord(var Values: TWordDynArray; Index: PtrInt);
var
n: PtrInt;
begin
n := Length(Values);
if PtrUInt(Index) >= PtrUInt(n) then
exit; // wrong Index
dec(n);
if n > Index then
begin
if PDACnt(PAnsiChar(Values) - _DACNT)^ > 1 then
MakeUniqueArray(pointer(Values), {shl=}1);
MoveFast(Values[Index + 1], Values[Index], (n - Index) * SizeOf(Word));
end;
SetLength(Values, n);
end;
procedure DeleteInteger(var Values: TIntegerDynArray; Index: PtrInt);
var
n: PtrInt;
begin
n := Length(Values);
if PtrUInt(Index) >= PtrUInt(n) then
exit; // wrong Index
dec(n);
if n > Index then
begin
if PDACnt(PAnsiChar(Values) - _DACNT)^ > 1 then
MakeUniqueArray(pointer(Values), {shl=}2);
MoveFast(Values[Index + 1], Values[Index], (n - Index) * SizeOf(integer));
end;
SetLength(Values, n);
end;
procedure DeleteInteger(var Values: TIntegerDynArray; var ValuesCount: integer; Index: PtrInt);
var
n: PtrInt;
begin
n := ValuesCount;
if PtrUInt(Index) >= PtrUInt(n) then
exit; // wrong Index
dec(n, Index + 1);
if n > 0 then
begin
if PDACnt(PAnsiChar(Values) - _DACNT)^ > 1 then
MakeUniqueArray(pointer(Values), {shl=}2);
MoveFast(Values[Index + 1], Values[Index], n * SizeOf(integer));
end;
dec(ValuesCount);
end;
procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt);
var
n: PtrInt;
begin
n := Length(Values);
if PtrUInt(Index) >= PtrUInt(n) then
exit; // wrong Index
dec(n);
if n > Index then
begin
if PDACnt(PAnsiChar(Values) - _DACNT)^ > 1 then
MakeUniqueArray(pointer(Values), {shl=}3);
MoveFast(Values[Index + 1], Values[Index], (n - Index) * SizeOf(Int64));
end;
SetLength(Values, n);
end;
procedure DeleteInt64(var Values: TInt64DynArray; var ValuesCount: integer; Index: PtrInt);
var
n: PtrInt;
begin
n := ValuesCount;
if PtrUInt(Index) >= PtrUInt(n) then
exit; // wrong Index
dec(n, Index + 1);
if n > 0 then
begin
if PDACnt(PAnsiChar(Values) - _DACNT)^ > 1 then
MakeUniqueArray(pointer(Values), {shl=}3);
MoveFast(Values[Index + 1], Values[Index], n * SizeOf(Int64));
end;
dec(ValuesCount);
end;
procedure FillIncreasing(Values: PIntegerArray; StartValue: integer; Count: PtrUInt);
var
i: PtrUInt;
begin
if Count > 0 then
if StartValue = 0 then
for i := 0 to Count - 1 do
Values[i] := i
else
for i := 0 to Count - 1 do
begin
Values[i] := StartValue;
inc(StartValue);
end;
end;
procedure QuickSortInteger(ID: PIntegerArray; L, R: PtrInt);
var
I, J, P: PtrInt;
tmp: integer;
begin
if L < R then
repeat
I := L;
J := R;
P := (L + R) shr 1;
repeat
tmp := ID[P];
if ID[I] < tmp then
repeat
inc(I)
until ID[I] >= tmp;
if ID[J] > tmp then
repeat
dec(J)
until ID[J] <= tmp;
if I <= J then
begin
tmp := ID[J];
ID[J] := ID[I];
ID[I] := tmp;
if P = I then
P := J
else if P = J then
P := I;
inc(I);
dec(J);
end;
until I > J;
if J - L < R - I then
begin
// use recursion only for smaller range
if L < J then
QuickSortInteger(ID, L, J);
L := I;
end
else
begin
if I < R then
QuickSortInteger(ID, I, R);
R := J;
end;
until L >= R;
end;
procedure QuickSortInteger(var ID: TIntegerDynArray);
begin
QuickSortInteger(pointer(ID), 0, high(ID));
end;
procedure QuickSortInteger(ID, CoValues: PIntegerArray; L, R: PtrInt);
var
I, J, P: PtrInt;
tmp: integer;
begin
if L < R then
repeat
I := L;
J := R;
P := (L + R) shr 1;
repeat
tmp := ID[P];
if ID[I] < tmp then
repeat
inc(I)
until ID[I] >= tmp;
if ID[J] > tmp then
repeat
dec(J)
until ID[J] <= tmp;
if I <= J then
begin
tmp := ID[J];
ID[J] := ID[I];
ID[I] := tmp;
tmp := CoValues[J];
CoValues[J] := CoValues[I];
CoValues[I] := tmp;
if P = I then
P := J
else if P = J then
P := I;
inc(I);
dec(J);
end;
until I > J;
if J - L < R - I then
begin
// use recursion only for smaller range
if L < J then
QuickSortInteger(ID, CoValues, L, J);
L := I;
end
else
begin
if I < R then
QuickSortInteger(ID, CoValues, I, R);
R := J;
end;
until L >= R;
end;
procedure QuickSortWord(ID: PWordArray; L, R: PtrInt);
var
I, J, P: PtrInt;
tmp: word;
begin
if L < R then
repeat
I := L;
J := R;
P := (L + R) shr 1;
repeat
tmp := ID[P];
if ID[I] < tmp then
repeat
inc(I)
until ID[I] >= tmp;
if ID[J] > tmp then
repeat
dec(J)
until ID[J] <= tmp;
if I <= J then
begin
tmp := ID[J];
ID[J] := ID[I];
ID[I] := tmp;
if P = I then
P := J
else if P = J then
P := I;
inc(I);
dec(J);
end;
until I > J;
if J - L < R - I then
begin
// use recursion only for smaller range
if L < J then
QuickSortWord(ID, L, J);
L := I;
end
else
begin
if I < R then
QuickSortWord(ID, I, R);
R := J;
end;
until L >= R;
end;
procedure QuickSortInt64(ID: PInt64Array; L, R: PtrInt);
var
I, J, P: PtrInt;
tmp: Int64;
begin
if L < R then
repeat
I := L;
J := R;
P := (L + R) shr 1;
repeat
{$ifdef CPU64}
tmp := ID^[P];
if ID[I] < tmp then
repeat
inc(I)
until ID[I] >= tmp;
if ID[J] > tmp then
repeat
dec(J)
until ID[J] <= tmp;
{$else}
while ID[I] < ID[P] do
inc(I);
while ID[J] > ID[P] do
dec(J);
{$endif CPU64}
if I <= J then
begin
tmp := ID[J];
ID[J] := ID[I];
ID[I] := tmp;
if P = I then
P := J
else if P = J then
P := I;
inc(I);
dec(J);
end;
until I > J;
if J - L < R - I then
begin
// use recursion only for smaller range
if L < J then
QuickSortInt64(ID, L, J);
L := I;
end
else
begin
if I < R then
QuickSortInt64(ID, I, R);
R := J;
end;
until L >= R;
end;
procedure QuickSortQWord(ID: PQWordArray; L, R: PtrInt);
var
I, J, P: PtrInt;
tmp: QWord;
begin
if L < R then
repeat
I := L;
J := R;
P := (L + R) shr 1;
repeat
{$ifdef CPUX86} // circumvent QWord comparison slowness (and bug)
while CompareQWord(ID[I], ID[P]) < 0 do
inc(I);
while CompareQWord(ID[J], ID[P]) > 0 do
dec(J);
{$else}
tmp := ID[P];
if ID[I] < tmp then
repeat
inc(I)
until ID[I] >= tmp;
if ID[J] > tmp then
repeat
dec(J)
until ID[J] <= tmp;
{$endif CPUX86}
if I <= J then
begin
tmp := ID[J];
ID[J] := ID[I];
ID[I] := tmp;
if P = I then
P := J
else if P = J then
P := I;
inc(I);
dec(J);
end;
until I > J;
if J - L < R - I then
begin
// use recursion only for smaller range
if L < J then
QuickSortQWord(ID, L, J);
L := I;
end
else
begin
if I < R then
QuickSortQWord(ID, I, R);
R := J;
end;
until L >= R;
end;
procedure QuickSortDouble(ID: PDoubleArray; L, R: PtrInt);
var
I, J, P: PtrInt;
tmp: double;
begin
if L < R then
repeat
I := L;
J := R;
P := (L + R) shr 1;
repeat
tmp := ID[P];
while ID[I] < tmp do
inc(I);
while ID[J] > tmp do
dec(J);
if I <= J then
begin
tmp := ID[J];
ID[J] := ID[I];
ID[I] := tmp;
if P = I then
P := J
else if P = J then
P := I;
inc(I);
dec(J);
end;
until I > J;
if J - L < R - I then
begin
// use recursion only for smaller range
if L < J then
QuickSortDouble(ID, L, J);
L := I;
end
else
begin
if I < R then
QuickSortDouble(ID, I, R);
R := J;
end;
until L >= R;
end;
procedure QuickSortInt64(ID, CoValues: PInt64Array; L, R: PtrInt);
var
I, J, P: PtrInt;
tmp: Int64;
begin
if L < R then
repeat
I := L;
J := R;
P := (L + R) shr 1;
repeat
{$ifdef CPU64}
tmp := ID^[P];
if ID[I] < tmp then
repeat
inc(I)
until ID[I] >= tmp;
if ID[J] > tmp then
repeat
dec(J)
until ID[J] <= tmp;
{$else}
while ID[I] < ID[P] do
inc(I);
while ID[J] > ID[P] do
dec(J);
{$endif CPU64}
if I <= J then
begin
tmp := ID[J];
ID[J] := ID[I];
ID[I] := tmp;
tmp := CoValues[J];
CoValues[J] := CoValues[I];
CoValues[I] := tmp;
if P = I then
P := J
else if P = J then
P := I;
inc(I);
dec(J);
end;
until I > J;
if J - L < R - I then
begin
// use recursion only for smaller range
if L < J then
QuickSortInt64(ID, CoValues, L, J);
L := I;
end
else
begin
if I < R then
QuickSortInt64(ID, CoValues, I, R);
R := J;
end;
until L >= R;
end;
function FastFindIntegerSorted(const Values: TIntegerDynArray; Value: integer): PtrInt;
begin
result := FastFindIntegerSorted(pointer(Values), Length(Values) - 1, Value);
end;
{$ifndef CPUX64} // x86_64 has fast branchless asm for those functions
function FastFindWordSorted(P: PWordArray; R: PtrInt; Value: Word): PtrInt;
var
L, RR: PtrInt;
cmp: integer;
begin
L := 0;
if 0 <= R then
repeat
result := (L + R) shr 1;
cmp := P^[result] - Value;
if cmp = 0 then
exit;
RR := result + 1; // compile as 2 branchless cmovc/cmovnc on FPC
dec(result);
if cmp < 0 then
L := RR
else
R := result;
until L > R;
result := -1
end;
function FastFindIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt;
var
L, RR: PtrInt;
cmp: integer;
begin
L := 0;
if 0 <= R then
repeat
result := (L + R) shr 1;
cmp := CompareInteger(P^[result], Value);
if cmp = 0 then
exit;
RR := result + 1; // compile as 2 branchless cmovc/cmovnc on FPC
dec(result);
if cmp < 0 then
L := RR
else
R := result;
until L > R;
result := -1
end;
function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt;
var
L, RR: PtrInt;
cmp: integer;
begin
L := 0;
if 0 <= R then
repeat
result := (L + R) shr 1;
cmp := CompareInt64(P^[result], Value);
if cmp = 0 then
exit;
RR := result + 1; // compile as 2 branchless cmovc/cmovnc on FPC
dec(result);
if cmp < 0 then
L := RR
else
R := result;
until L > R;
result := -1
end;
{$endif CPUX64}
function FastFindQWordSorted(P: PQWordArray; R: PtrInt; const Value: QWord): PtrInt;
var
L, RR: PtrInt;
cmp: integer;
begin
L := 0;
if 0 <= R then
repeat
result := (L + R) shr 1;
cmp := CompareQWord(P^[result], Value);
if cmp = 0 then
exit;
RR := result + 1; // compile as 2 branchless cmovc/cmovnc on FPC
dec(result);
if cmp < 0 then
L := RR
else
R := result;
until L > R;
result := -1
end;
function FastLocateIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt;
var
L, RR: PtrInt;
cmp: integer;
begin
if R < 0 then
result := 0
else
begin
L := 0;
repeat
result := (L + R) shr 1;
cmp := P^[result] - Value;
if cmp = 0 then
begin
result := -result - 1; // return -(foundindex+1) if already exists
exit;
end;
RR := result + 1; // compile as 2 branchless cmovl/cmovge on FPC
dec(result);
if cmp < 0 then
L := RR
else
R := result;
until L > R;
while (result >= 0) and
(P^[result] >= Value) do
dec(result);
inc(result); // return the index where to insert
end;
end;
function FastSearchIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt;
var
L, RR: PtrInt;
cmp: integer;
begin
if R < 0 then
result := 0
else
begin
L := 0;
repeat
result := (L + R) shr 1;
cmp := P^[result] - Value;
if cmp = 0 then
exit; // return exact matching index
RR := result + 1; // compile as 2 branchless cmovl/cmovge on FPC
dec(result);
if cmp < 0 then
L := RR
else
R := result;
until L > R;
while (result >= 0) and
(P^[result] >= Value) do
dec(result);
inc(result); // return the index where to insert
end;
end;
function FastLocateWordSorted(P: PWordArray; R: integer; Value: word): PtrInt;
var
L, cmp: PtrInt;
begin
if R < 0 then
result := 0
else
begin
L := 0;
repeat
result := (L + R) shr 1;
cmp := P^[result] - Value;
if cmp = 0 then
begin
result := -result - 1; // return -(foundindex+1) if already exists
exit;
end;
if cmp < 0 then
L := result + 1
else
R := result - 1;
until L > R;
while (result >= 0) and
(P^[result] >= Value) do
dec(result);
inc(result); // return the index where to insert
end;
end;
function AddSortedInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Value: integer; CoValues: PIntegerDynArray): PtrInt;
begin
result := FastLocateIntegerSorted(pointer(Values), ValuesCount - 1, Value);
if result >= 0 then // if Value exists -> fails and return -(foundindex+1)
result := InsertInteger(Values, ValuesCount, Value, result, CoValues);
end;
function AddSortedInteger(var Values: TIntegerDynArray; Value: integer;
CoValues: PIntegerDynArray): PtrInt;
var
ValuesCount: integer;
begin
ValuesCount := Length(Values);
result := FastLocateIntegerSorted(pointer(Values), ValuesCount - 1, Value);
if result < 0 then
exit; // Value exists -> fails and return -(foundindex+1)
SetLength(Values, ValuesCount + 1); // manual size increase
result := InsertInteger(Values, ValuesCount, Value, result, CoValues);
end;
function InsertInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
Value: integer; Index: PtrInt; CoValues: PIntegerDynArray): PtrInt;
var
n: PtrInt;
begin
result := Index;
n := Length(Values);
if ValuesCount = n then
begin
n := NextGrow(n);
SetLength(Values, n);
if CoValues <> nil then
SetLength(CoValues^, n);
end;
n := ValuesCount;
if PtrUInt(result) < PtrUInt(n) then
begin
n := (n - result) * SizeOf(integer);
MoveFast(Values[result], Values[result + 1], n);
if CoValues <> nil then
MoveFast(CoValues^[result], CoValues^[result + 1], n);
end
else
result := n;
Values[result] := Value;
inc(ValuesCount);
end;
function TIntegerDynArrayFrom(const Values: array of integer): TIntegerDynArray;
var
i: PtrInt;
begin
Finalize(result);
SetLength(result, Length(Values));
for i := 0 to high(Values) do
result[i] := Values[i];
end;
function TIntegerDynArrayFrom64(const Values: TInt64DynArray;
raiseExceptionOnOverflow: boolean): TIntegerDynArray;
var
i: PtrInt;
const
MinInt = -MaxInt - 1;
begin
Finalize(result);
SetLength(result, Length(Values));
for i := 0 to Length(Values) - 1 do
if Values[i] > MaxInt then
if raiseExceptionOnOverflow then
raise Exception.CreateFmt('TIntegerDynArrayFrom64: Values[%d]=%d>%d',
[i, Values[i], MaxInt])
else
result[i] := MaxInt
else if Values[i] < MinInt then
if raiseExceptionOnOverflow then
raise Exception.CreateFmt('TIntegerDynArrayFrom64: Values[%d]=%d<%d',
[i, Values[i], MinInt])
else
result[i] := MinInt
else
result[i] := Values[i];
end;
function TInt64DynArrayFrom(const Values: TIntegerDynArray): TInt64DynArray;
var
i: PtrInt;
begin
Finalize(result);
SetLength(result, Length(Values));
for i := 0 to Length(Values) - 1 do
result[i] := Values[i];
end;
function TQWordDynArrayFrom(const Values: TCardinalDynArray): TQWordDynArray;
var
i: PtrInt;
begin
Finalize(result);
SetLength(result, Length(Values));
for i := 0 to Length(Values) - 1 do
result[i] := Values[i];
end;
function FromI32(const Values: array of integer): TIntegerDynArray;
var
i: PtrInt;
begin
Finalize(result);
SetLength(result, Length(Values));
for i := 0 to high(Values) do
result[i] := Values[i];
end;
function FromU32(const Values: array of cardinal): TCardinalDynArray;
var
i: PtrInt;
begin
Finalize(result);
SetLength(result, Length(Values));
for i := 0 to high(Values) do
result[i] := Values[i];
end;
function FromI64(const Values: array of Int64): TInt64DynArray;
var
i: PtrInt;
begin
Finalize(result);
SetLength(result, Length(Values));
for i := 0 to high(Values) do
result[i] := Values[i];
end;
function FromU64(const Values: array of QWord): TQWordDynArray;
var
i: PtrInt;
begin
Finalize(result);
SetLength(result, Length(Values));
for i := 0 to high(Values) do
result[i] := Values[i];
end;
function gcd(a, b: PtrUInt): PtrUInt;
begin
result := 0;
if a <> 0 then
while b <> 0 do
begin
result := b;
b := a mod b;
a := result;
end;
end;
{ TSortedWordArray }
function TSortedWordArray.Add(aValue: Word): PtrInt;
begin
result := Count; // optimistic check of perfectly increasing aValue
if (result > 0) and
(aValue <= Values[result - 1]) then
result := FastLocateWordSorted(pointer(Values), result - 1, aValue);
if result < 0 then // aValue already exists in Values[] -> fails
exit;
if Count = Length(Values) then
SetLength(Values, NextGrow(Count));
if result < Count then
MoveFast(Values[result], Values[result + 1], (Count - result) * SizeOf(word))
else
result := Count;
Values[result] := aValue;
inc(Count);
end;
function TSortedWordArray.IndexOf(aValue: Word): PtrInt;
begin
result := FastFindWordSorted(pointer(Values), Count - 1, aValue);
end;
procedure TSortedWordArray.SetArray(out aValues: TWordDynArray);
begin
if Count = 0 then
exit;
DynArrayFakeLength(Values, Count); // no realloc needed
aValues := Values;
end;
{ TSortedIntegerArray }
function TSortedIntegerArray.Add(aValue: integer): PtrInt;
begin
result := Count; // optimistic check of perfectly increasing aValue
if (result > 0) and
(aValue <= Values[result - 1]) then
result := FastLocateIntegerSorted(pointer(Values), result - 1, aValue);
if result < 0 then // aValue already exists in Values[] -> fails
exit;
if Count = Length(Values) then
SetLength(Values, NextGrow(Count));
if result < Count then
MoveFast(Values[result], Values[result + 1], (Count - result) * SizeOf(integer))
else
result := Count;
Values[result] := aValue;
inc(Count);
end;
function TSortedIntegerArray.IndexOf(aValue: integer): PtrInt;
begin
result := FastFindIntegerSorted(pointer(Values), Count - 1, aValue);
end;
procedure TSortedIntegerArray.SetArray(out aValues: TIntegerDynArray);
begin
if Count = 0 then
exit;
DynArrayFakeLength(Values, Count); // no realloc needed
aValues := Values;
end;
{ ************ ObjArray PtrArray InterfaceArray Wrapper Functions }
{ PtrArr* wrapper functions }
function PtrArrayAdd(var aPtrArray; aItem: pointer): integer;
var
a: TPointerDynArray absolute aPtrArray;
begin
result := length(a);
SetLength(a, result + 1);
a[result] := aItem;
end;
function PtrArrayAdd(var aPtrArray; aItem: pointer; var aPtrArrayCount: integer): PtrInt;
var
a: TPointerDynArray absolute aPtrArray;
begin
result := aPtrArrayCount;
if result = length(a) then
SetLength(a, NextGrow(result));
a[result] := aItem;
inc(aPtrArrayCount);
end;
function PtrArrayAddOnce(var aPtrArray; aItem: pointer): PtrInt;
var
a: TPointerDynArray absolute aPtrArray;
n: PtrInt;
begin
n := length(a);
result := PtrUIntScanIndex(pointer(a), n, PtrUInt(aItem));
if result >= 0 then
exit;
SetLength(a, n + 1);
a[n] := aItem;
result := n;
end;
function PtrArrayAddOnce(var aPtrArray; aItem: pointer;
var aPtrArrayCount: integer): PtrInt;
begin
result := PtrUIntScanIndex(pointer(aPtrArray), aPtrArrayCount, PtrUInt(aItem));
if result < 0 then
result := PtrArrayAdd(aPtrArray, aItem, aPtrArrayCount);
end;
function PtrArrayInsert(var aPtrArray; aItem: pointer; aIndex: PtrInt;
var aPtrArrayCount: integer): PtrInt;
var
a: TPointerDynArray absolute aPtrArray;
n: PtrInt;
begin
n := aPtrArrayCount;
if length(a) = n then
SetLength(a, NextGrow(n));
if PtrUInt(aIndex) < PtrUInt(n) then
MoveFast(a[aIndex], a[aIndex + 1], (n - aIndex) * SizeOf(pointer))
else
aIndex := n;
a[aIndex] := aItem;
inc(aPtrArrayCount);
result := aIndex;
end;
procedure PtrArrayDelete(var aPtrArray; aIndex: PtrInt; aCount: PInteger);
var
a: TPointerDynArray absolute aPtrArray;
n: PtrInt;
begin
if aCount = nil then
n := length(a)
else
n := aCount^;
if PtrUInt(aIndex) >= PtrUInt(n) then
exit; // out of range
dec(n);
if n > aIndex then
MoveFast(a[aIndex + 1], a[aIndex], (n - aIndex) * SizeOf(pointer));
a[n] := nil; // better safe than sorry
if aCount = nil then
if n and 255 <> 0 then
DynArrayFakeLength(a, n) // call ReallocMem() once every 256 deletes
else
SetLength(a, n) // finalize if n = 0
else
begin
aCount^ := n;
if n = 0 then
Finalize(a);
end;
end;
function PtrArrayDelete(var aPtrArray; aItem: pointer; aCount: PInteger): PtrInt;
var
a: TPointerDynArray absolute aPtrArray;
n: PtrInt;
begin
if aCount = nil then
n := length(a)
else
n := aCount^;
result := PtrUIntScanIndex(pointer(a), n, PtrUInt(aItem));
if result < 0 then
exit;
dec(n);
if n > result then
MoveFast(a[result + 1], a[result], (n - result) * SizeOf(pointer));
a[n] := nil; // better safe than sorry
if aCount = nil then
SetLength(a, n)
else
begin
aCount^ := n;
if n = 0 then
Finalize(a);
end;
end;
function PtrArrayFind(var aPtrArray; aItem: pointer): integer;
var
a: TPointerDynArray absolute aPtrArray;
begin
result := PtrUIntScanIndex(pointer(a), length(a), PtrUInt(aItem));
end;
{ wrapper functions to T*ObjArr types }
function ObjArrayAdd(var aObjArray; aItem: TObject): PtrInt;
begin
result := PtrArrayAdd(aObjArray, aItem);
end;
function ObjArrayAddCount(var aObjArray; aItem: TObject; var aObjArrayCount: integer): PtrInt;
begin
result := PtrArrayAdd(aObjArray, aItem, aObjArrayCount);
end;
function ObjArrayAddFrom(var aDestObjArray; const aSourceObjArray): PtrInt;
var
n: PtrInt;
s: TObjectDynArray absolute aSourceObjArray;
d: TObjectDynArray absolute aDestObjArray;
begin
result := length(d);
n := length(s);
SetLength(d, result + n);
MoveFast(s[0], d[result], n * SizeOf(pointer));
inc(result, n);
end;
function ObjArrayAppend(var aDestObjArray, aSourceObjArray): PtrInt;
begin
result := ObjArrayAddFrom(aDestObjArray, aSourceObjArray);
TObjectDynArray(aSourceObjArray) := nil; // aSourceObjArray[] changed ownership
end;
function ObjArrayAddOnce(var aObjArray; aItem: TObject): PtrInt;
begin
result := PtrArrayAddOnce(aObjArray, aItem);
end;
function ObjArrayAddOnce(var aObjArray; aItem: TObject;
var aObjArrayCount: integer): PtrInt;
begin
result := PtrArrayAddOnce(aObjArray, aItem, aObjArrayCount);
end;
function ObjArrayAddOnceFrom(var aDestObjArray; const aSourceObjArray): PtrInt;
var
n, i: PtrInt;
s: TObjectDynArray absolute aSourceObjArray;
d: TObjectDynArray absolute aDestObjArray;
begin
result := length(d);
n := length(s);
if n = 0 then
exit;
SetLength(d, result + n);
for i := 0 to n - 1 do
if not PtrUIntScanExists(pointer(d), result, PtrUInt(s[i])) then
begin
d[result] := s[i];
inc(result);
end;
DynArrayFakeLength(d, result);
end;
procedure ObjArraySetLength(var aObjArray; aLength: integer);
begin
SetLength(TObjectDynArray(aObjArray), aLength);
end;
function ObjArrayFind(const aObjArray; aItem: TObject): PtrInt;
begin
result := PtrUIntScanIndex(
pointer(aObjArray), length(TObjectDynArray(aObjArray)), PtrUInt(aItem));
end;
function ObjArrayFind(const aObjArray; aCount: integer; aItem: TObject): PtrInt;
begin
result := PtrUIntScanIndex(pointer(aObjArray), aCount, PtrUInt(aItem));
end;
function ObjArrayNotNilCount(const aObjArray): integer;
var
i: PtrInt;
a: TObjectDynArray absolute aObjArray;
begin
result := 0;
for i := 0 to length(a) - 1 do
inc(result, ord(a[i] <> nil));
end;
procedure ObjArrayDelete(var aObjArray; aItemIndex: PtrInt;
aContinueOnException: boolean; aCount: PInteger);
var
n: PtrInt;
a: TObjectDynArray absolute aObjArray;
begin
if aCount = nil then
n := length(a)
else
n := aCount^;
if cardinal(aItemIndex) >= cardinal(n) then
exit; // out of range
if aContinueOnException then
try
a[aItemIndex].Free;
except
end
else
a[aItemIndex].Free;
dec(n);
if n > aItemIndex then
MoveFast(a[aItemIndex + 1], a[aItemIndex], (n - aItemIndex) * SizeOf(TObject));
if aCount = nil then
if n = 0 then
Finalize(a)
else
DynArrayFakeLength(a, n)
else
aCount^ := n;
end;
function ObjArrayDelete(var aObjArray; aItem: TObject): PtrInt;
begin
result := PtrUIntScanIndex(pointer(aObjArray), length(TObjectDynArray(aObjArray)), PtrUInt(aItem));
if result >= 0 then
ObjArrayDelete(aObjArray, result);
end;
function ObjArrayDelete(var aObjArray; aCount: integer; aItem: TObject): PtrInt; overload;
begin
result := PtrUIntScanIndex(pointer(aObjArray), aCount, PtrUInt(aItem));
if result >= 0 then
ObjArrayDelete(aObjArray, result, false, @aCount);
end;
procedure RawObjectsClear(o: PObject; n: integer);
var
obj: TObject;
begin
if n > 0 then
repeat
obj := o^;
if obj <> nil then
begin
// inlined FreeAndNil(o^)
o^ := nil;
obj.Destroy;
end;
inc(o);
dec(n);
until n = 0;
end;
procedure FreeAndNilSafe(var aObj);
begin
if TObject(aObj) = nil then
exit;
try // slower but paranoidically safe
TObject(aObj).Destroy;
except
end;
TObject(aObj) := nil; // we could do it AFTER destroy
end;
procedure InterfaceNilSafe(var aInterface);
begin
if IInterface(aInterface) <> nil then
try // slower but paranoidically safe
IInterface(aInterface) := nil;
except
pointer(aInterface) := nil; // force variable to nil
end;
end;
procedure InterfacesNilSafe(const aInterfaces: array of pointer);
var
i: PtrInt;
begin
for i := 0 to high(aInterfaces) do
InterfaceNilSafe(aInterfaces[i]^);
end;
procedure ObjArrayClear(var aObjArray);
var
a: TObjectDynArray absolute aObjArray;
begin
if a = nil then
exit;
// release all owned TObject instances
RawObjectsClear(pointer(aObjArray), PDALen(PAnsiChar(a) - _DALEN)^ + _DAOFF);
// release the dynamic array itself
a := nil;
end;
procedure ObjArrayClear(var aObjArray; aCount: integer);
var
a: TObjectDynArray absolute aObjArray;
n: integer;
begin
n := length(a);
if n = 0 then
exit;
if n < aCount then
aCount := n;
RawObjectsClear(pointer(aObjArray), aCount);
a := nil;
end;
procedure ObjArrayClear(var aObjArray; aContinueOnException: boolean; aCount: PInteger);
var
n, i: PtrInt;
a: TObjectDynArray absolute aObjArray;
begin
if aCount = nil then
n := length(a)
else
begin
n := aCount^;
aCount^ := 0;
end;
if n = 0 then
exit;
if aContinueOnException then
for i := n - 1 downto 0 do
try
a[i].Free;
except
end
else
RawObjectsClear(pointer(a), n);
a := nil; // finalize the dynamic array itself
end;
procedure ObjArrayObjArrayClear(var aObjArray);
var
i: PtrInt;
a: TPointerDynArray absolute aObjArray;
begin
if a <> nil then
begin
for i := 0 to length(a) - 1 do
ObjArrayClear(a[i]);
a := nil;
end;
end;
procedure ObjArraysClear(const aObjArray: array of pointer);
var
i: PtrInt;
begin
for i := 0 to high(aObjArray) do
if aObjArray[i] <> nil then
ObjArrayClear(aObjArray[i]^);
end;
{ wrapper functions to array of interface types }
function InterfaceArrayAdd(var aInterfaceArray; const aItem: IUnknown): PtrInt;
var
a: TInterfaceDynArray absolute aInterfaceArray;
begin
result := length(a);
SetLength(a, result + 1);
a[result] := aItem;
end;
function InterfaceArrayAddCount(var aInterfaceArray; var aCount: integer;
const aItem: IUnknown): PtrInt;
var
a: TInterfaceDynArray absolute aInterfaceArray;
begin
result := aCount;
if result = length(a) then
SetLength(a, NextGrow(result));
a[result] := aItem;
inc(aCount);
end;
procedure InterfaceArrayAddOnce(var aInterfaceArray; const aItem: IUnknown);
var
a: TInterfaceDynArray absolute aInterfaceArray;
n: PtrInt;
begin
if PtrUIntScanExists(pointer(aInterfaceArray),
length(TInterfaceDynArray(aInterfaceArray)), PtrUInt(aItem)) then
exit;
n := length(a);
SetLength(a, n + 1);
a[n] := aItem;
end;
function InterfaceArrayFind(const aInterfaceArray; const aItem: IUnknown): PtrInt;
begin
result := PtrUIntScanIndex(pointer(aInterfaceArray), length(TInterfaceDynArray(aInterfaceArray)), PtrUInt(aItem));
end;
procedure InterfaceArrayDelete(var aInterfaceArray; aItemIndex: PtrInt);
var
n: PtrInt;
a: TInterfaceDynArray absolute aInterfaceArray;
begin
n := length(a);
if PtrUInt(aItemIndex) >= PtrUInt(n) then
exit; // out of range
a[aItemIndex] := nil;
dec(n);
if n > aItemIndex then
MoveFast(a[aItemIndex + 1], a[aItemIndex], (n - aItemIndex) * SizeOf(IInterface));
TPointerDynArray(aInterfaceArray)[n] := nil; // avoid GPF in SetLength()
if n = 0 then
Finalize(a)
else
DynArrayFakeLength(a, n);
end;
function InterfaceArrayDelete(var aInterfaceArray; const aItem: IUnknown): PtrInt;
begin
result := InterfaceArrayFind(aInterfaceArray, aItem);
if result >= 0 then
InterfaceArrayDelete(aInterfaceArray, result);
end;
{ ************ low-level types mapping binary structures }
function IsZero(const dig: THash128): boolean;
var
a: TPtrIntArray absolute dig;
begin
result := a[0] or a[1] {$ifdef CPU32} or a[2] or a[3]{$endif} = 0;
end;
function IsEqual(const A, B: THash128): boolean;
var
a_: TPtrIntArray absolute A;
b_: TPtrIntArray absolute B;
begin
// uses anti-forensic time constant "xor/or" pattern
result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) {$ifdef CPU32} or
(a_[2] xor b_[2]) or (a_[3] xor b_[3]) {$endif} ) = 0;
end;
procedure FillZero(out dig: THash128);
var
d: TInt64Array absolute dig;
begin
d[0] := 0;
d[1] := 0;
end;
{$ifdef CPU64}
function Hash128Index(P: PHash128Rec; Count: integer; h: PHash128Rec): integer;
var
_0, _1: PtrInt; // is likely to use CPU registers
begin
if P <> nil then
begin
_0 := h^.Lo;
_1 := h^.Hi;
for result := 0 to Count - 1 do
if (P^.Lo = _0) and
(P^.Hi = _1) then
exit
else
inc(P);
end;
result := -1; // not found
end;
function Hash256Index(P: PHash256Rec; Count: integer; h: PHash256Rec): integer;
var
_0, _1: PtrInt;
begin
if P <> nil then
begin
_0 := h^.d0;
_1 := h^.d1;
for result := 0 to Count - 1 do
if (P^.d0 = _0) and
(P^.d1 = _1) and
(P^.d2 = h^.d2) and
(P^.d3 = h^.d3) then
exit
else
inc(P);
end;
result := -1; // not found
end;
{$else}
function Hash128Index(P: PHash128Rec; Count: integer; h: PHash128Rec): integer;
begin
if P <> nil then
for result := 0 to Count - 1 do
if (P^.i0 = h^.i0) and
(P^.i1 = h^.i1) and
(P^.i2 = h^.i2) and
(P^.i3 = h^.i3) then
exit
else
inc(P);
result := -1; // not found
end;
function Hash256Index(P: PHash256Rec; Count: integer; h: PHash256Rec): integer;
begin
if P <> nil then
for result := 0 to Count - 1 do
if (P^.i0 = h^.i0) and
(P^.i1 = h^.i1) and
(P^.i2 = h^.i2) and
(P^.i3 = h^.i3) and
(P^.i4 = h^.i4) and
(P^.i5 = h^.i5) and
(P^.i6 = h^.i6) and
(P^.i7 = h^.i7) then
exit
else
inc(P);
result := -1; // not found
end;
{$endif CPU64}
function AddHash128(var Arr: THash128DynArray; const V: THash128;
var Count: integer): PtrInt;
begin
result := Count;
if result = length(Arr) then
SetLength(Arr, NextGrow(result));
Arr[result] := V;
inc(Count);
end;
function IsZero(const dig: THash160): boolean;
var
a: TIntegerArray absolute dig;
begin
result := a[0] or a[1] or a[2] or a[3] or a[4] = 0;
end;
function IsEqual(const A, B: THash160): boolean;
var
a_: TIntegerArray absolute A;
b_: TIntegerArray absolute B;
begin
// uses anti-forensic time constant "xor/or" pattern
result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or
(a_[3] xor b_[3]) or (a_[4] xor b_[4])) = 0;
end;
procedure FillZero(out dig: THash160);
begin
PInt64Array(@dig)^[0] := 0;
PInt64Array(@dig)^[1] := 0;
PIntegerArray(@dig)^[4] := 0;
end;
function IsZero(const dig: THash256): boolean;
var
a: TPtrIntArray absolute dig;
begin
result := a[0] or a[1] or a[2] or a[3] {$ifdef CPU32} or
a[4] or a[5] or a[6] or a[7] {$endif} = 0;
end;
function IsEqual(const A, B: THash256): boolean;
var
a_: TPtrIntArray absolute A;
b_: TPtrIntArray absolute B;
begin
// uses anti-forensic time constant "xor/or" pattern
result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or
(a_[3] xor b_[3]) {$ifdef CPU32} or (a_[4] xor b_[4]) or (a_[5] xor b_[5]) or
(a_[6] xor b_[6]) or (a_[7] xor b_[7]) {$endif} ) = 0;
end;
procedure FillZero(out dig: THash256);
var
d: TInt64Array absolute dig;
begin
d[0] := 0;
d[1] := 0;
d[2] := 0;
d[3] := 0;
end;
function IsZero(const dig: THash384): boolean;
var
a: TPtrIntArray absolute dig;
begin
result := a[0] or a[1] or a[2] or a[3] or a[4] or a[5] {$ifdef CPU32} or
a[6] or a[7] or a[8] or a[9] or a[10] or a[11] {$endif} = 0;
end;
function IsEqual(const A, B: THash384): boolean;
var
a_: TPtrIntArray absolute A;
b_: TPtrIntArray absolute B;
begin
// uses anti-forensic time constant "xor/or" pattern
result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or
(a_[3] xor b_[3]) or (a_[4] xor b_[4]) or (a_[5] xor b_[5]) {$ifdef CPU32} or
(a_[6] xor b_[6]) or (a_[7] xor b_[7]) or (a_[8] xor b_[8]) or
(a_[9] xor b_[9]) or (a_[10] xor b_[10]) or (a_[11] xor b_[11]) {$endif}) = 0;
end;
procedure FillZero(out dig: THash384);
var
d: TInt64Array absolute dig;
begin
d[0] := 0;
d[1] := 0;
d[2] := 0;
d[3] := 0;
d[4] := 0;
d[5] := 0;
end;
function IsZero(const dig: THash512): boolean;
var
a: TPtrIntArray absolute dig;
begin
result := a[0] or a[1] or a[2] or a[3] or a[4] or a[5] or a[6] or a[7] {$ifdef CPU32}
or a[8] or a[9] or a[10] or a[11] or a[12] or a[13] or a[14] or a[15] {$endif} = 0;
end;
function IsEqual(const A, B: THash512): boolean;
var
a_: TPtrIntArray absolute A;
b_: TPtrIntArray absolute B;
begin
// uses anti-forensic time constant "xor/or" pattern
result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or
(a_[3] xor b_[3]) or (a_[4] xor b_[4]) or (a_[5] xor b_[5]) or
(a_[6] xor b_[6]) or (a_[7] xor b_[7]) {$ifdef CPU32} or
(a_[8] xor b_[8]) or (a_[9] xor b_[9]) or (a_[10] xor b_[10]) or
(a_[11] xor b_[11]) or (a_[12] xor b_[12]) or (a_[13] xor b_[13]) or
(a_[14] xor b_[14]) or (a_[15] xor b_[15]) {$endif}) = 0;
end;
procedure FillZero(out dig: THash512);
var
d: TInt64Array absolute dig;
begin
d[0] := 0;
d[1] := 0;
d[2] := 0;
d[3] := 0;
d[4] := 0;
d[5] := 0;
d[6] := 0;
d[7] := 0;
end;
function IsEqual(const A, B; count: PtrInt): boolean;
var
perbyte: boolean; // ensure no optimization takes place
begin
result := true;
while count > 0 do
begin
dec(count);
perbyte := PByteArray(@A)[count] = PByteArray(@B)[count];
result := result and perbyte;
end;
end;
{$ifdef ISDELPHI} // intrinsic in FPC
{$ifdef CPUINTEL}
procedure ReadBarrier;
asm
{$ifdef CPUX86}
lock add dword ptr [esp], 0
{$else}
.noframe
lfence // lfence requires an SSE CPU, which is OK on x86-64
{$endif CPUX86}
end;
{$else}
procedure ReadBarrier;
begin
MemoryBarrier; // modern Delphi intrinsic
end;
{$endif CPUINTEL}
{$endif ISDELPHI}
procedure Rcu32(var src, dst);
begin
repeat
integer(dst) := integer(src);
ReadBarrier;
until integer(dst) = integer(src);
end;
procedure Rcu64(var src, dst);
begin
repeat
Int64(dst) := Int64(src);
ReadBarrier;
until Int64(dst) = Int64(src);
end;
procedure RcuPtr(var src, dst);
begin
repeat
PtrInt(dst) := PtrInt(src);
ReadBarrier;
until PtrInt(dst) = PtrInt(src);
end;
procedure Rcu128(var src, dst);
var
s: THash128Rec absolute src;
d: THash128Rec absolute dst;
begin
repeat
d := s;
ReadBarrier;
until (d.L = s.L) and
(d.H = s.H);
end;
procedure Rcu(var src, dst; len: integer);
begin
if len > 0 then
repeat
MoveByOne(@src, @dst, len); // per-byte inlined copy
ReadBarrier;
until CompareMemSmall(@src, @dst, len);
end;
{ ************ low-level functions manipulating bits }
// naive code gives the best performance - bts [Bits] has an overhead
// we tried with PPtrIntArray but PIntegerArray seems to generate better code
function GetBit(const Bits; aIndex: PtrInt): boolean;
begin
result := TIntegerArray(Bits)[aIndex shr 5] and (1 shl (aIndex and 31)) <> 0;
end;
procedure SetBit(var Bits; aIndex: PtrInt);
begin
TIntegerArray(Bits)[aIndex shr 5] :=
TIntegerArray(Bits)[aIndex shr 5] or (1 shl (aIndex and 31));
end;
procedure UnSetBit(var Bits; aIndex: PtrInt);
begin
PIntegerArray(@Bits)^[aIndex shr 5] :=
PIntegerArray(@Bits)^[aIndex shr 5] and not (1 shl (aIndex and 31));
end;
function GetBitPtr(Bits: pointer; aIndex: PtrInt): boolean;
begin
result := PIntegerArray(Bits)[aIndex shr 5] and (1 shl (aIndex and 31)) <> 0;
end;
procedure SetBitPtr(Bits: pointer; aIndex: PtrInt);
begin
PIntegerArray(Bits)[aIndex shr 5] :=
PIntegerArray(Bits)[aIndex shr 5] or (1 shl (aIndex and 31));
end;
procedure UnSetBitPtr(Bits: pointer; aIndex: PtrInt);
begin
PIntegerArray(Bits)^[aIndex shr 5] :=
PIntegerArray(Bits)^[aIndex shr 5] and not (1 shl (aIndex and 31));
end;
function GetBit64(const Bits: Int64; aIndex: PtrInt): boolean;
begin
result := byte(aIndex) in TBits64(Bits);
end;
procedure SetBit64(var Bits: Int64; aIndex: PtrInt);
begin
include(PBits64(@Bits)^, aIndex);
end;
procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt);
begin
exclude(PBits64(@Bits)^, aIndex);
end;
function GetBitsCount(const Bits; Count: PtrInt): PtrInt;
var
P: PPtrInt;
popcnt: function(value: PtrInt): PtrInt; // fast redirection within loop
begin
P := @Bits;
result := 0;
popcnt := @GetBitsCountPtrInt;
if Count >= POINTERBITS then
repeat
dec(Count, POINTERBITS);
inc(result, popcnt(P^)); // use SSE4.2 if available
inc(P);
until Count < POINTERBITS;
if Count > 0 then
inc(result, popcnt(P^ and ((PtrInt(1) shl Count) - 1)));
end;
function GetAllBits(Bits, BitCount: cardinal): boolean;
begin
if (BitCount >= low(ALLBITS_CARDINAL)) and
(BitCount <= high(ALLBITS_CARDINAL)) then
begin
BitCount := ALLBITS_CARDINAL[BitCount];
result := (Bits and BitCount) = BitCount;
end
else
result := false;
end;
function BitsToBytes(bits: byte): byte;
begin
result := (bits + 7) shr 3;
end;
{ ************ Faster alternative to RTL standard functions }
{$ifndef CPUX86} // those functions have their own PIC-compatible x86 asm version
function StrLenSafe(S: pointer): PtrInt;
begin
result := PtrUInt(S);
if S <> nil then
repeat
if PAnsiChar(result)[0] <> #0 then
if PAnsiChar(result)[1] <> #0 then
if PAnsiChar(result)[2] <> #0 then
if PAnsiChar(result)[3] <> #0 then
begin
inc(result, 4);
continue;
end
else
begin
dec(result, PtrUInt(S) - 3);
exit;
end
else
begin
dec(result, PtrUInt(S) - 2);
exit;
end
else
dec(PtrUInt(S));
dec(result, PtrUInt(S));
exit;
until false;
end;
function StrComp(Str1, Str2: pointer): PtrInt;
var
c: byte;
begin
result := 0;
if Str1 <> nil then
if Str2 <> nil then
begin
dec(PtrUInt(Str1), PtrUInt(Str2));
if Str1 = nil then
exit; // Str1=Str2
repeat
c := PByteArray(Str1)[PtrUInt(Str2)];
if c <> PByte(Str2)^ then
break
else if c = 0 then
exit // Str1 = Str2
else
inc(PByte(Str2));
until false;
result := PByteArray(Str1)[PtrUInt(Str2)] - PByte(Str2)^;
exit;
end
else
inc(result) // Str2=''
else if Str2 <> nil then
dec(result); // Str1=''
end;
// from A. Sharahov's PosEx_Sha_Pas_2() - refactored for cross-platform/compiler
function PosExPas(pSub, p: PUtf8Char; Offset: PtrUInt): PtrInt;
var
len, lenSub: PtrInt;
ch: AnsiChar;
pStart, pStop: PUtf8Char;
label
s2, s6, tt, t0, t1, t2, t3, t4, s0, s1, fnd, quit;
begin
result := 0;
if (p = nil) or
(pSub = nil) or
(PtrInt(Offset) <= 0) then
goto quit;
len := PStrLen(p - _STRLEN)^;
lenSub := PStrLen(pSub - _STRLEN)^ - 1;
if (len < lenSub + PtrInt(Offset)) or
(lenSub < 0) then
goto quit;
pStop := p + len;
inc(p, lenSub);
inc(pSub, lenSub);
pStart := p;
p := @p[Offset + 3];
ch := pSub[0];
lenSub := -lenSub;
if p < pStop then
goto s6;
dec(p, 4);
goto s2;
s6: // check 6 chars per loop iteration
if ch = p[-4] then
goto t4;
if ch = p[-3] then
goto t3;
if ch = p[-2] then
goto t2;
if ch = p[-1] then
goto t1;
s2:if ch = p[0] then
goto t0;
s1:if ch = p[1] then
goto tt;
s0:inc(p, 6);
if p < pStop then
goto s6;
dec(p, 4);
if p >= pStop then
goto quit;
goto s2;
t4:dec(p, 2);
t2:dec(p, 2);
goto t0;
t3:dec(p, 2);
t1:dec(p, 2);
tt:len := lenSub;
if lenSub <> 0 then
repeat
if (pSub[len] <> p[len + 1]) or
(pSub[len + 1] <> p[len + 2]) then
goto s0;
inc(len, 2);
until len >= 0;
inc(p, 2);
if p <= pStop then
goto fnd;
goto quit;
t0:len := lenSub;
if lenSub <> 0 then
repeat
if (pSub[len] <> p[len]) or
(pSub[len + 1] <> p[len + 1]) then
goto s1;
inc(len, 2);
until len >= 0;
inc(p);
fnd:
result := p - pStart;
quit:
end;
function PosEx(const SubStr, S: RawUtf8; Offset: PtrUInt): PtrInt;
begin
result := PosExPas(pointer(SubStr), pointer(S), Offset); // inlined call
end;
{$endif CPUX86}
function StrCompW(Str1, Str2: PWideChar): PtrInt;
var
c: word;
begin
result := 0;
if Str1 <> Str2 then
if Str1 <> nil then
if Str2 <> nil then
begin
repeat
c := PWord(Str1)^;
if c <> PWord(Str2)^ then
break
else if c = 0 then
exit; // Str1 = Str2
inc(Str1);
inc(Str2);
until false;
result := PWord(Str1)^ - PWord(Str2)^;
end
else
inc(result) // Str2=''
else
dec(result); // Str1=''
end;
function PosExChar(Chr: AnsiChar; const Str: RawUtf8): PtrInt;
begin
if Str <> '' then
result := ByteScanIndex(pointer(Str), PStrLen(PtrUInt(Str) - _STRLEN)^, byte(Chr)) + 1
else
result := 0;
end;
function PosChar(Str: PUtf8Char; StrLen: PtrInt; Chr: AnsiChar): PUtf8Char;
begin
if StrLen <> 0 then
begin
StrLen := ByteScanIndex(pointer(Str), StrLen, byte(Chr));
if StrLen >= 0 then
result := Str + StrLen
else
result := nil;
end
else
result := nil;
end;
{$ifdef UNICODE}
function PosExString(const SubStr, S: string; Offset: PtrUInt): PtrInt;
begin
result := PosExStringPas(pointer(SubStr), pointer(S), Offset);
end;
function PosExStringPas(pSub, p: PChar; Offset: PtrUInt): PtrInt;
var
len, lenSub: PtrInt;
ch: char;
pStart, pStop: PChar;
label
Loop2, Loop6, TestT, Test0, Test1, Test2, Test3, Test4,
AfterTestT, AfterTest0, Ret, Exit;
begin
result := 0;
if (p = nil) or
(pSub = nil) or
(PtrInt(Offset) <= 0) then
goto Exit;
len := PStrLen(PtrUInt(p) - _STRLEN)^;
lenSub := PStrLen(PtrUInt(pSub) - _STRLEN)^ - 1;
if (len < lenSub + PtrInt(Offset)) or
(lenSub < 0) then
goto Exit;
pStop := p + len;
inc(p, lenSub);
inc(pSub, lenSub);
pStart := p;
inc(p, Offset + 3);
ch := pSub[0];
lenSub := -lenSub;
if p < pStop then
goto Loop6;
dec(p, 4);
goto Loop2;
Loop6: // check 6 chars per loop iteration
if ch = p[-4] then
goto Test4;
if ch = p[-3] then
goto Test3;
if ch = p[-2] then
goto Test2;
if ch = p[-1] then
goto Test1;
Loop2:
if ch = p[0] then
goto Test0;
AfterTest0:
if ch = p[1] then
goto TestT;
AfterTestT:
inc(p, 6);
if p < pStop then
goto Loop6;
dec(p, 4);
if p >= pStop then
goto Exit;
goto Loop2;
Test4:
dec(p, 2);
Test2:
dec(p, 2);
goto Test0;
Test3:
dec(p, 2);
Test1:
dec(p, 2);
TestT:
len := lenSub;
if lenSub <> 0 then
repeat
if (pSub[len] <> p[len + 1]) or
(pSub[len + 1] <> p[len + 2]) then
goto AfterTestT;
inc(len, 2);
until len >= 0;
inc(p, 2);
if p <= pStop then
goto Ret;
goto Exit;
Test0:
len := lenSub;
if lenSub <> 0 then
repeat
if (pSub[len] <> p[len]) or
(pSub[len + 1] <> p[len + 1]) then
goto AfterTest0;
inc(len, 2);
until len >= 0;
inc(p);
Ret:
result := p - pStart;
Exit:
end;
{$else}
function PosExString(const SubStr, S: string; Offset: PtrUInt): PtrInt;
begin
{$ifdef CPUX86}
result := PosEx(SubStr, S, Offset); // call x86 asm
{$else}
result := PosExPas(pointer(SubStr), pointer(S), Offset);
{$endif CPUX86}
end;
{$endif UNICODE}
function TrimU(const S: RawUtf8): RawUtf8;
var
i, L: PtrInt;
begin
L := Length(S);
i := 1;
while (i <= L) and
(S[i] <= ' ') do
inc(i);
if i > L then
FastAssignNew(result) // void string
else if (i = 1) and
(S[L] > ' ') then
result := S // nothing to trim: reference counted copy
else
begin
while S[L] <= ' ' do
dec(L);
dec(i);
FastSetString(result, @PByteArray(S)[i], L - i); // trim and allocate
end;
end;
procedure TrimSelf(var S: RawUtf8);
var
i, L: PtrInt;
begin
if S = '' then
exit;
L := PStrLen(PAnsiChar(pointer(S)) - _STRLEN)^;
i := 1;
while (i <= L) and
(S[i] <= ' ') do
inc(i);
if i > L then
FastAssignNew(S) // void string
else if (i = 1) and
(S[L] > ' ') then
exit // nothing to trim
else
begin
// trim the UTF-8 string
while S[L] <= ' ' do
dec(L);
dec(i);
dec(L, i);
if (L <> 0) and
(PStrCnt(PAnsiChar(pointer(S)) - _STRCNT)^ = 1) then
begin
if i <> 0 then
MoveFast(PByteArray(S)[i], pointer(S)^, L); // trim left: move in place
FakeLength(S, L); // after move, to properly set ending #0
end
else
FastSetString(S, @PByteArray(S)[i], L); // allocate
end;
end;
{$ifndef PUREMORMOT2}
function Trim(const S: RawUtf8): RawUtf8;
begin
result := TrimU(S);
end;
{$endif PUREMORMOT2}
procedure TrimCopy(const S: RawUtf8; start, count: PtrInt;
var result: RawUtf8); // faster alternative to TrimU(copy())
var
L: PtrInt;
begin
if count > 0 then
begin
if start <= 0 then
start := 1;
L := Length(S);
while (start <= L) and
(S[start] <= ' ') do
begin
inc(start);
dec(count);
end;
dec(start);
dec(L,start);
if count < L then
L := count;
while L > 0 do
if S[start + L] <= ' ' then
dec(L)
else
break;
if L > 0 then
begin
FastSetString(result, @PByteArray(S)[start], L);
exit;
end;
end;
result := '';
end;
function Split(const Str, SepStr: RawUtf8; StartPos: PtrInt): RawUtf8;
var
len, i: PtrInt;
begin
len := length(Str);
if len = 0 then
begin
result := '';
exit;
end;
if StartPos > len then
StartPos := len
else if StartPos <= 0 then
StartPos := 1;
if (length(SepStr) = 1) and
(StartPos <= 1) then
i := PosExChar(SepStr[1], Str) // may use SSE2 on i386/x86_64
else
i := PosEx(SepStr, Str, StartPos);
if i > 0 then
FastSetString(result, @PByteArray(Str)[StartPos - 1], i - StartPos)
else if StartPos = 1 then
result := Str
else
FastSetString(result, @PByteArray(Str)[StartPos - 1], len - StartPos + 1);
end;
function StrLenW(S: PWideChar): PtrInt;
begin
result := 0;
if S <> nil then
while true do
if S[result + 0] <> #0 then
if S[result + 1] <> #0 then
if S[result + 2] <> #0 then
if S[result + 3] <> #0 then
inc(result, 4)
else
begin
inc(result, 3);
exit;
end
else
begin
inc(result, 2);
exit;
end
else
begin
inc(result);
exit;
end
else
exit;
end;
function GotoNextControlChar(source: PUtf8Char): PUtf8Char;
label
_1, _2, _3; // ugly but faster
begin
result := source;
repeat
if result[0] < #13 then
exit
else if result[1] < #13 then
goto _1
else if result[2] < #13 then
goto _2
else if result[3] < #13 then
goto _3
else
begin
inc(result, 4);
continue;
end;
_3: inc(result);
_2: inc(result);
_1: inc(result);
exit;
until false;
end;
function GotoNextLine(source: PUtf8Char): PUtf8Char;
label
_0, _1, _2, _3; // ugly but faster
begin
repeat
if source[0] < #13 then
goto _0
else if source[1] < #13 then
goto _1
else if source[2] < #13 then
goto _2
else if source[3] < #13 then
goto _3
else
begin
inc(source, 4);
continue;
end;
_3: inc(source);
_2: inc(source);
_1: inc(source);
_0: if source[0] = #13 then
begin
if source[1] = #10 then
begin
result := source + 2; // most common case is text ending with #13#10
exit;
end;
end
else if source[0] = #0 then
begin
result := nil; // premature ending
exit;
end
else if source[0] <> #10 then
begin
inc(source);
continue; // e.g. #9
end;
result := source + 1;
exit;
until false;
end;
function IsAnsiCompatible(PC: PAnsiChar): boolean;
begin
result := false;
if PC <> nil then
while true do
if PC^ = #0 then
break
else if PC^ <= #127 then
// 7-bit chars are always OK, whatever codepage/charset is used
inc(PC)
else
exit;
result := true;
end;
function IsAnsiCompatible(PC: PAnsiChar; Len: PtrUInt): boolean;
begin
if PC <> nil then
begin
result := false;
Len := PtrUInt(@PC[Len - 4]);
if Len >= PtrUInt(PC) then
repeat
if PCardinal(PC)^ and $80808080 <> 0 then
exit;
inc(PC, 4);
until Len < PtrUInt(PC);
inc(Len, 4);
if Len > PtrUInt(PC) then
repeat
if PC^ > #127 then
exit;
inc(PC);
until Len <= PtrUInt(PC);
end;
result := true;
end;
function IsAnsiCompatible(const Text: RawByteString): boolean;
begin
result := IsAnsiCompatible(PAnsiChar(pointer(Text)), Length(Text));
end;
function IsAnsiCompatibleW(PW: PWideChar): boolean;
begin
result := false;
if PW <> nil then
while true do
if ord(PW^) = 0 then
break
else if ord(PW^) <= 127 then
inc(PW)
else // 7-bit chars are always OK, whatever codepage/charset is used
exit;
result := true;
end;
function IsAnsiCompatibleW(PW: PWideChar; Len: PtrInt): boolean;
begin
result := false;
if (PW <> nil) and
(Len > 0) then
repeat
if ord(PW^) > 127 then
exit;
inc(PW);
dec(Len);
until Len = 0;
result := true;
end;
procedure StrCntAdd(var refcnt: TStrCnt; increment: TStrCnt);
begin
{$ifdef STRCNT32}
LockedAdd32(cardinal(refcnt), increment);
{$else}
LockedAdd(PtrUInt(refcnt), increment);
{$endif STRCNT32}
end;
procedure DACntAdd(var refcnt: TDACnt; increment: TDACnt);
begin
{$ifdef DACNT32}
LockedAdd32(cardinal(refcnt), increment);
{$else}
LockedAdd(PtrUInt(refcnt), increment);
{$endif DACNT32}
end;
procedure FillZero(var dest; count: PtrInt);
begin
FillCharFast(dest, count, 0);
end;
procedure MoveAndZero(Source, Dest: Pointer; Count: PtrUInt);
begin
if Count = 0 then
exit;
MoveFast(Source^, Dest^, Count);
FillCharFast(Source^, Count, 0);
end;
procedure FillZeroSmall(P: pointer; Length: PtrInt);
begin
inc(PtrUInt(P), PtrUInt(Length));
Length := -Length;
repeat
PByteArray(P)[Length] := 0;
inc(Length);
until Length = 0;
end;
threadvar // do not publish for compilation within Delphi packages
_Lecuyer: TLecuyer; // uses only 16 bytes per thread
function Lecuyer: PLecuyer;
begin
result := @_Lecuyer;
end;
{$ifdef OSDARWIN} // FPC CreateGuid calls /dev/urandom which is not advised
function mach_absolute_time: Int64; cdecl external 'c';
function mach_continuous_time: Int64; cdecl external 'c';
procedure CreateGuid(var guid: TGuid); // sysutils version is slow
begin
PInt64Array(@guid)^[0] := mach_absolute_time; // monotonic time (in ns)
PInt64Array(@guid)^[1] := mach_continuous_time;
crc128c(@guid, SizeOf(guid), THash128(guid)); // good enough diffusion
end;
{$endif OSDARWIN}
var
// cascaded 128-bit random to avoid replay attacks - shared by all threads
_EntropyGlobal: THash128Rec;
procedure XorEntropy(var e: THash512Rec);
var
lec: PLecuyer;
guid: THash128Rec;
begin
// note: we don't use RTL Random() here because it is not thread-safe
if _EntropyGlobal.L = 0 then
sysutils.CreateGuid(_EntropyGlobal.guid); // slow but rich initial value
e.r[0].L := e.r[0].L xor _EntropyGlobal.L;
e.r[0].H := e.r[0].H xor _EntropyGlobal.H;
lec := @_Lecuyer; // lec^.rs#=0 at thread startup, but won't hurt
e.r[1].c0 := e.r[1].c0 xor lec^.RawNext; // perfect forward security
e.r[1].c1 := e.r[1].c1 xor lec^.RawNext; // but don't expose rs1,rs2,rs3
e.r[1].c2 := e.r[1].c2 xor lec^.RawNext;
// any threadvar is thread-specific, so PtrUInt(lec) identifies this thread
{$ifdef CPUINTELARM}
e.r[1].c3 := e.r[1].c3 xor crc32c(PtrUInt(lec), @CpuFeatures, SizeOf(CpuFeatures));
{$else}
e.r[1].c3 := e.r[1].c3 xor PtrUInt(lec);
{$endif CPUINTELARM}
// Windows CoCreateGuid, Linux /proc/sys/kernel/random/uuid, FreeBSD syscall,
// then fallback to /dev/urandom or RTL mtwist_u32rand
CreateGuid(guid.guid); // not from sysutils: redefined above for OSDARWIN
e.r[2].L := e.r[2].L xor guid.L;
e.r[2].H := e.r[2].H xor guid.H;
// no mormot.core.os yet, so we can't use QueryPerformanceMicroSeconds()
unaligned(PDouble(@e.r[3].Lo)^) := Now * 2123923447; // cross-platform time
{$ifdef CPUINTEL} // use low-level Intel/AMD opcodes
e.r[3].Lo := e.r[3].Lo xor Rdtsc;
RdRand32(@e.r[0].c, length(e.r[0].c));
e.r[3].Hi := e.r[3].Hi xor Rdtsc; // has slightly changed in-between
{$else}
{$ifdef OSDARWIN} // fallback to known OS API on Mac M1/M2
e.r[3].Lo := e.r[3].Lo xor mach_absolute_time; // as defined above
e.r[3].Hi := e.r[3].Hi xor mach_continuous_time;
{$endif OSDARWIN}
e.r[3].Hi := e.r[3].Hi xor GetTickCount64; // always defined in FPC RTL
{$endif CPUINTEL}
crc128c(@e, SizeOf(e), _EntropyGlobal.b); // simple diffusion to move forward
end;
procedure MoveSwap(dst, src: PByte; n: PtrInt);
begin
if n <= 0 then
exit;
inc(dst, n);
repeat
dec(dst);
dst^ := src^;
inc(src);
dec(n);
until n = 0;
end;
procedure TLecuyer.Seed(entropy: PByteArray; entropylen: PtrInt);
var
e: THash512Rec;
h: THash128Rec;
i, j: PtrInt;
begin
if entropy <> nil then
for i := 0 to entropylen - 1 do
begin
j := i and (SizeOf(e) - 1); // insert into the 64 bytes of e.b[]
e.b[j] := {%H-}e.b[j] xor entropy^[i];
end;
repeat
XorEntropy(e); // 512-bit from RdRand32 + Rdtsc + Now + CreateGuid
DefaultHasher128(@h, @e, SizeOf(e)); // may be AesNiHash128
rs1 := rs1 xor h.c0;
rs2 := rs2 xor h.c1;
rs3 := rs3 xor h.c2;
until (rs1 > 1) and
(rs2 > 7) and
(rs3 > 15);
seedcount := h.c3 shr 24; // may seed slightly before 2^32 of output data
for i := 1 to h.i3 and 7 do
RawNext; // warm up
end;
procedure TLecuyer.SeedGenerator(fixedseed: QWord);
begin
SeedGenerator(@fixedseed, SizeOf(fixedseed));
end;
procedure TLecuyer.SeedGenerator(fixedseed: pointer; fixedseedbytes: integer);
begin
rs1 := crc32c(0, fixedseed, fixedseedbytes);
rs2 := crc32c(rs1, fixedseed, fixedseedbytes);
rs3 := crc32c(rs2, fixedseed, fixedseedbytes);
if rs1 < 2 then
rs1 := 2;
if rs2 < 8 then
rs2 := 8;
if rs3 < 16 then
rs3 := 16;
seedcount := 1; // will reseet after 16 GB, i.e. 2^32 of output data
end;
function TLecuyer.RawNext: cardinal;
begin // not inlined for better code generation
result := rs1;
rs1 := ((result and -2) shl 12) xor (((result shl 13) xor result) shr 19);
result := rs2;
rs2 := ((result and -8) shl 4) xor (((result shl 2) xor result) shr 25);
result := rs3;
rs3 := ((result and -16) shl 17) xor (((result shl 3) xor result) shr 11);
result := rs1 xor rs2 xor result;
end;
function TLecuyer.Next: cardinal;
begin
if seedcount = 0 then
Seed // seed at startup, and after 2^32 of output data = 16 GB
else
inc(seedcount);
result := RawNext;
end;
function TLecuyer.Next(max: cardinal): cardinal;
begin
result := (QWord(Next) * max) shr 32;
end;
function TLecuyer.NextQWord: QWord;
begin
PQWordRec(@result)^.L := Next;
PQWordRec(@result)^.H := RawNext; // no need to check the Seed twice
end;
function TLecuyer.NextDouble: double;
const
COEFF32: double = 1.0 / (Int64(1) shl 32);
begin
result := Next * COEFF32; // 32-bit resolution is enough for our purpose
end;
procedure TLecuyer.Fill(dest: pointer; bytes: integer);
var
c: cardinal;
begin
if bytes <= 0 then
exit;
c := seedcount;
inc(seedcount, cardinal(bytes) shr 2);
if (c = 0) or // first use = seed at startup
(c > seedcount) then // check for 32-bit overflow, i.e. after 16 GB
Seed;
repeat
if bytes < 4 then
break;
PCardinal(dest)^ := PCardinal(dest)^ xor RawNext; // inlining won't change
inc(PCardinal(dest));
dec(bytes, 4);
if bytes = 0 then
exit;
until false;
c := RawNext;
repeat
PByte(dest)^ := PByte(dest)^ xor c;
inc(PByte(dest));
c := c shr 8;
dec(bytes);
until bytes = 0;
end;
procedure FillAnsiStringFromRandom(dest: PByteArray; size: PtrUInt);
var
len: PtrUInt;
begin
dec(size);
len := dest[0]; // first random byte will make length
if size = 31 then
size := len and 31 // optimized for FillShort31()
else if size = 255 then
size := ToByte(len)
else
size := len mod size;
dest[0] := size;
if size <> 0 then
repeat
dest[size] := (cardinal(dest[size]) and 63) + 32;
dec(size);
until size = 0;
end;
procedure TLecuyer.FillShort(var dest: ShortString; size: PtrUInt);
begin
if size = 0 then
begin
dest[0] := #0;
exit;
end;
if size > 255 then
size := 256
else
inc(size);
Fill(@dest, size);
FillAnsiStringFromRandom(@dest, size);
end;
procedure TLecuyer.FillShort31(var dest: TShort31);
begin
Fill(@dest, 32);
FillAnsiStringFromRandom(@dest, 32);
end;
procedure Random32Seed(entropy: pointer; entropylen: PtrInt);
begin
_Lecuyer.Seed(entropy, entropylen);
end;
function Random32: cardinal;
begin
result := _Lecuyer.Next;
end;
function Random31: integer;
begin
result := _Lecuyer.Next shr 1;
end;
function Random32(max: cardinal): cardinal;
begin
result := (QWord(_Lecuyer.Next) * max) shr 32;
end;
function Random64: QWord;
begin
result := _Lecuyer.NextQWord;
end;
function RandomDouble: double;
begin
result := _Lecuyer.NextDouble;
end;
procedure RandomBytes(Dest: PByte; Count: integer);
begin
if Count > 0 then
_Lecuyer.Fill(pointer(Dest), Count);
end;
procedure RandomShort31(var dest: TShort31);
begin
_Lecuyer.FillShort31(dest);
end;
procedure LecuyerEncrypt(key: Qword; var data: RawByteString);
var
gen: TLecuyer;
begin
if data = '' then
exit;
{$ifdef FPC}
UniqueString(data); // @data[1] won't call UniqueString() under FPC :(
{$endif FPC}
gen.SeedGenerator(key);
gen.Fill(@data[1], length(data));
FillZero(THash128(gen)); // to avoid forensic leak
end;
{$ifndef PUREMORMOT2}
procedure FillRandom(Dest: PCardinal; CardinalCount: integer);
begin
if CardinalCount > 0 then
_Lecuyer.Fill(pointer(Dest), CardinalCount shl 2);
end;
{$endif PUREMORMOT2}
{ MultiEvent* functions }
function MultiEventFind(const EventList; const Event: TMethod): PtrInt;
var
Events: TMethodDynArray absolute EventList;
begin
if Event.Code <> nil then // callback assigned
for result := 0 to length(Events) - 1 do
if (Events[result].Code = Event.Code) and
(Events[result].Data = Event.Data) then
exit;
result := -1;
end;
function MultiEventAdd(var EventList; const Event: TMethod): boolean;
var
Events: TMethodDynArray absolute EventList;
n: PtrInt;
begin
result := false;
n := MultiEventFind(EventList, Event);
if n >= 0 then
exit; // already registered
result := true;
n := length(Events);
SetLength(Events, n + 1);
Events[n] := Event;
end;
procedure MultiEventRemove(var EventList; const Event: TMethod);
begin
MultiEventRemove(EventList, MultiEventFind(EventList, Event));
end;
procedure MultiEventRemove(var EventList; Index: integer);
var
Events: TMethodDynArray absolute EventList;
max: integer;
begin
max := length(Events);
if cardinal(Index) < cardinal(max) then
begin
dec(max);
MoveFast(Events[Index + 1], Events[Index], (max - Index) * SizeOf(Events[Index]));
SetLength(Events, max);
end;
end;
procedure MultiEventMerge(var DestList; const ToBeAddedList);
var
Dest: TMethodDynArray absolute DestList;
New: TMethodDynArray absolute ToBeAddedList;
d, n: PtrInt;
begin
d := length(Dest);
n := length(New);
if n = 0 then
exit;
SetLength(Dest, d + n);
MoveFast(New[0], Dest[d], n * SizeOf(TMethod));
end;
function EventEquals(const eventA, eventB): boolean;
var
A: TMethod absolute eventA;
B: TMethod absolute eventB;
begin
result := (A.Code = B.Code) and
(A.Data = B.Data);
end;
type
// 16KB/32KB hash table used by SynLZ - as used by the asm .inc files
TOffsets = array[0..4095] of PAnsiChar;
{$ifdef CPUINTEL}
// optimized asm for x86 and x86_64 is located in include files
{$ifndef HASNOSSE2}
function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal;
begin
Count := IntegerScanIndex(P, Count, Value); // SSE2 asm on Intel/AMD
if Count >= 0 then
result := @P[Count]
else
result := nil;
end;
function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean;
begin
result := IntegerScanIndex(P, Count, Value) >= 0; // SSE2 asm on Intel/AMD
end;
{$endif HASNOSSE2}
function HasHWAes: boolean;
begin
result := cfAESNI in CpuFeatures;
end;
procedure RdRand32(buffer: PCardinal; n: integer);
begin
if (n > 0) and
(cfRAND in CpuFeatures) then
repeat
buffer^ := buffer^ xor RdRand32;
inc(buffer);
dec(n);
until n = 0;
end;
type
TIntelRegisters = record
eax, ebx, ecx, edx: cardinal;
end;
{$ifdef CPUX64}
{$include mormot.core.base.asmx64.inc}
{$endif CPUX64}
{$ifdef CPUX86}
{$include mormot.core.base.asmx86.inc}
{$endif CPUX86}
procedure TestCpuFeatures;
var
regs: TIntelRegisters;
c: cardinal;
begin
// retrieve CPUID raw flags
FillChar(regs, SizeOf(regs), 0); // no FillCharFast here
GetCpuid({eax=}1, {ecx=}0, regs);
PIntegerArray(@CpuFeatures)^[0] := regs.edx;
PIntegerArray(@CpuFeatures)^[1] := regs.ecx;
GetCpuid(7, 0, regs);
PIntegerArray(@CpuFeatures)^[2] := regs.ebx;
PIntegerArray(@CpuFeatures)^[3] := regs.ecx;
PIntegerArray(@CpuFeatures)^[4] := regs.edx;
if regs.eax in [1..9] then // returned the maximum ecx value for eax=7 in eax
begin
GetCpuid(7, 1, regs);
PIntegerArray(@CpuFeatures)^[5] := regs.eax; // just ignore regs.ebx
PIntegerArray(@CpuFeatures)^[6] := regs.edx;
if cfAVX10 in CpuFeatures then
begin
GetCpuid($24, 0, regs);
CpuAvx10.MaxSubLeaf := regs.eax;
CpuAvx10.Version := ToByte(regs.ebx);
PByte(@CpuAvx10.Vector)^ := (regs.ebx shr 16) and 7;
end;
end;
// validate accuracy of most used HW opcodes
{$ifdef DISABLE_SSE42}
// force fallback on Darwin x64 (as reported by alf) - clang asm bug?
CpuFeatures := CpuFeatures -
[cfSSE3, cfSSE42, cfPOPCNT, cfAESNI, cfCLMUL, cfAVX, cfAVX2, cfFMA];
{$else}
if not (cfOSXS in CpuFeatures) or
not IsXmmYmmOSEnabled then
// AVX is available on the CPU, but not supported at OS context switch
CpuFeatures := CpuFeatures - [cfAVX, cfAVX2, cfFMA];
{$endif DISABLE_SSE42}
if cfRAND in CpuFeatures then
try
c := RdRand32;
if RdRand32 = c then // most probably a RDRAND bug, e.g. on AMD Rizen 3000
exclude(CpuFeatures, cfRAND);
except // may trigger an illegal instruction exception on some Ivy Bridge
exclude(CpuFeatures, cfRAND);
end;
if cfSSE42 in CpuFeatures then
try
if crc32cby4sse42(0, 1) <> 3712330424 then
exclude(CpuFeatures, cfSSE42);
except // disable now on illegal instruction or incorrect result
exclude(CpuFeatures, cfSSE42);
end;
if cfPOPCNT in CpuFeatures then
try
if GetBitsCountSse42(7) = 3 then
GetBitsCountPtrInt := @GetBitsCountSse42;
except // clearly invalid opcode
exclude(CpuFeatures, cfPOPCNT);
end;
{$ifdef ASMX64}
// note: cfERMS has no cpuid within some VMs -> ignore and assume present
if cfAVX in CpuFeatures then
begin
include(X64CpuFeatures, cpuAVX);
if cfAVX2 in CpuFeatures then
include(X64CpuFeatures, cpuAVX2);
if CpuFeatures * CPUAVX2HASWELL = CPUAVX2HASWELL then
include(X64CpuFeatures, cpuHaswell);
end;
{$endif ASMX64}
// redirect some CPU-aware functions
{$ifdef ASMX86}
{$ifndef HASNOSSE2}
{$ifdef WITH_ERMS}
if not (cfSSE2 in CpuFeatures) then
begin
ERMSB_MIN_SIZE_FWD := 0; // FillCharFast fallbacks to rep stosb on older CPU
{$ifndef FPC_X86}
ERMSB_MIN_SIZE_BWD := 0; // in both directions to bypass the SSE2 code
{$endif FPC_X86}
end
// but MoveFast/SynLz are likely to abort -> recompile with HASNOSSE2 conditional
// note: mormot.core.os.pas InitializeSpecificUnit will notify it on console
else if cfERMS in CpuFeatures then
ERMSB_MIN_SIZE_FWD := 4096; // "on 32-bit strings have to be at least 4KB"
// backward rep movsd has no ERMS optimization so degrades performance
{$endif WITH_ERMS}
{$endif HASNOSSE2}
if cfSSE2 in CpuFeatures then
StrLen := @StrLenSSE2;
{$endif ASMX86}
if cfSSE42 in CpuFeatures then // for both i386 and x86_64
begin
crc32c := @crc32csse42;
crc32cby4 := @crc32cby4sse42;
crcblock := @crcblocksse42;
crcblocks := @crcblockssse42;
DefaultHasher := @crc32csse42;
InterningHasher := @crc32csse42;
end;
end;
{$else not CPUINTEL}
// fallback to pure pascal version for non-Intel CPUs
function Hash32(Data: PCardinalArray; Len: integer): cardinal;
var
s1, s2: cardinal;
i: integer;
begin
if Data <> nil then
begin
s1 := 0;
s2 := 0;
for i := 1 to Len shr 4 do
begin
// 16 bytes (128-bit) loop - aligned read
inc(s1, Data[0]);
inc(s2, s1);
inc(s1, Data[1]);
inc(s2, s1);
inc(s1, Data[2]);
inc(s2, s1);
inc(s1, Data[3]);
inc(s2, s1);
Data := @Data[4];
end;
for i := 1 to (Len shr 2) and 3 do
begin
// 4 bytes (DWORD) by loop
inc(s1, Data[0]);
inc(s2, s1);
Data := @Data[1];
end;
case Len and 3 of // remaining 0..3 bytes
1:
inc(s1, PByte(Data)^);
2:
inc(s1, PWord(Data)^);
3:
inc(s1, PWord(Data)^ or (PByteArray(Data)^[2] shl 16));
end;
inc(s2, s1);
result := s1 xor (s2 shl 16);
end
else
result := 0;
end;
const
PRIME32_1 = 2654435761;
PRIME32_2 = 2246822519;
PRIME32_3 = 3266489917;
PRIME32_4 = 668265263;
PRIME32_5 = 374761393;
{$ifdef FPC} // RolDWord is an intrinsic function under FPC :)
function Rol13(value: cardinal): cardinal; inline;
begin
result := RolDWord(value, 13);
end;
{$else}
function RolDWord(value: cardinal; count: integer): cardinal; inline;
begin
result := (value shl count) or (value shr (32 - count));
end;
function Rol13(value: cardinal): cardinal; inline;
begin
result := (value shl 13) or (value shr 19);
end;
{$endif FPC}
function xxHash32(crc: cardinal; P: PAnsiChar; len: cardinal): cardinal;
var
c1, c2, c3, c4: cardinal;
PLimit, PEnd: PAnsiChar;
begin
PEnd := P + len;
if len >= 16 then
begin
PLimit := PEnd - 16;
c3 := crc;
c2 := c3 + PRIME32_2;
c1 := c2 + PRIME32_1;
c4 := c3 - PRIME32_1;
repeat
c1 := PRIME32_1 * Rol13(c1 + PRIME32_2 * PCardinal(P)^);
c2 := PRIME32_1 * Rol13(c2 + PRIME32_2 * PCardinal(P + 4)^);
c3 := PRIME32_1 * Rol13(c3 + PRIME32_2 * PCardinal(P + 8)^);
c4 := PRIME32_1 * Rol13(c4 + PRIME32_2 * PCardinal(P + 12)^);
inc(P, 16);
until not (P <= PLimit);
result := RolDWord(c1, 1) + RolDWord(c2, 7) + RolDWord(c3, 12) + RolDWord(c4, 18);
end
else
result := crc + PRIME32_5;
inc(result, len);
while P + 4 <= PEnd do
begin
inc(result, PCardinal(P)^ * PRIME32_3);
result := RolDWord(result, 17) * PRIME32_4;
inc(P, 4);
end;
while P < PEnd do
begin
inc(result, PByte(P)^ * PRIME32_5);
result := RolDWord(result, 11) * PRIME32_1;
inc(P);
end;
result := result xor (result shr 15); // inlined xxHash32Mixup()
result := result * PRIME32_2;
result := result xor (result shr 13);
result := result * PRIME32_3;
result := result xor (result shr 16);
end;
function SortDynArrayInteger(const A, B): integer;
begin
result := ord(integer(A) > integer(B)) - ord(integer(A) < integer(B));
end;
function SortDynArrayCardinal(const A, B): integer;
begin
result := ord(cardinal(A) > cardinal(B)) - ord(cardinal(A) < cardinal(B));
end;
function SortDynArrayInt64(const A, B): integer;
begin
result := ord(Int64(A) > Int64(B)) - ord(Int64(A) < Int64(B));
end;
function SortDynArrayQWord(const A, B): integer;
begin
result := ord(QWord(A) > QWord(B)) - ord(QWord(A) < QWord(B));
end;
function SortDynArrayPointer(const A, B): integer;
begin
result := ord(PtrUInt(A) > PtrUInt(B)) - ord(PtrUInt(A) < PtrUInt(B));
end;
function SortDynArrayDouble(const A, B): integer;
begin
result := ord(double(A) > double(B)) - ord(double(A) < double(B));
end;
function SortDynArraySingle(const A, B): integer;
begin
result := ord(single(A) > single(B)) - ord(single(A) < single(B));
end;
function SortDynArrayAnsiString(const A, B): integer;
begin
result := StrComp(pointer(A), pointer(B));
end;
function SortDynArrayRawByteString(const A, B): integer;
var
p1, p2: PByteArray;
l1, l2: PtrInt; // FPC will use very efficiently the CPU registers
begin
// we can't use StrComp() since a RawByteString may contain #0
p1 := pointer(A);
p2 := pointer(B);
if p1 <> p2 then
if p1 <> nil then
if p2 <> nil then
begin
result := p1[0] - p2[0]; // compare first char for quicksort
if result <> 0 then
exit;
l1 := PStrLen(PtrUInt(p1) - _STRLEN)^;
l2 := PStrLen(PtrUInt(p2) - _STRLEN)^;
result := l1;
if l1 > l2 then
l1 := l2;
dec(result, l2);
p1 := @p1[l1];
p2 := @p2[l1];
dec(l1); // we already compared the first char
if l1 = 0 then
exit;
l1 := -l1;
repeat
if p1[l1] <> p2[l1] then
break;
inc(l1);
if l1 = 0 then
exit;
until false;
result := p1[l1] - p2[l1];
end
else
result := 1 // p2=''
else
result := -1 // p1=''
else
result := 0; // p1=p2
end;
{ FPC x86_64 Linux:
1000000 pas in 4.67ms i.e. 213,949,507/s, aver. 0us, 1.5 GB/s
1000000 asm in 4.14ms i.e. 241,196,333/s, aver. 0us, 1.8 GB/s
1000000 sse4.2 in 2.36ms i.e. 423,011,844/s, aver. 0us, 3.1 GB/s
1000000 FPC in 21.32ms i.e. 46,886,721/s, aver. 0us, 357.7 MB/s
FPC i386 Windows:
1000000 pas in 3.40ms i.e. 293,944,738/s, aver. 0us, 1 GB/s
1000000 asm in 3.18ms i.e. 313,971,742/s, aver. 0us, 1.1 GB/s
1000000 sse4.2 in 2.74ms i.e. 364,166,059/s, aver. 0us, 1.3 GB/s
1000000 FPC in 8.18ms i.e. 122,204,570/s, aver. 0us, 466.1 MB/s
notes:
1. AVX2 faster than popcnt on big buffers - https://arxiv.org/pdf/1611.07612.pdf
2. our pascal/asm versions below use the efficient Wilkes-Wheeler-Gill algorithm
whereas FPC RTL's popcnt() is much slower }
function GetBitsCountPas(value: PtrInt): PtrInt;
begin
// generic branchless Wilkes-Wheeler-Gill pure pascal version
result := value;
{$ifdef CPU64}
result := result - ((result shr 1) and $5555555555555555);
result := (result and $3333333333333333) + ((result shr 2) and $3333333333333333);
result := (result + (result shr 4)) and $0f0f0f0f0f0f0f0f;
inc(result, result shr 8); // avoid slow multiplication on ARM
inc(result, result shr 16);
inc(result, result shr 32);
result := result and $7f;
{$else}
result := result - ((result shr 1) and $55555555);
result := (result and $33333333) + ((result shr 2) and $33333333);
result := (result + (result shr 4)) and $0f0f0f0f;
inc(result, result shr 8);
inc(result, result shr 16);
result := result and $3f;
{$endif CPU64}
end;
procedure mul64x64(constref left, right: QWord; out product: THash128Rec);
var
l: TQWordRec absolute left;
r: TQWordRec absolute right;
t1, t2: TQWordRec;
begin
// CPU-neutral implementation
t1.V := QWord(l.L) * r.L;
product.c0 := t1.L;
t2.V := QWord(l.H) * r.L + t1.H;
t1.V := QWord(l.L) * r.H + t2.L;
product.H := QWord(l.H) * r.H + t2.H + t1.H;
product.c1 := t1.V;
end;
function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
begin
result := SynLZcompress1pas(src, size, dst);
end;
function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
begin
result := SynLZdecompress1pas(src, size, dst);
end;
function StrCntDecFree(var refcnt: TStrCnt): boolean;
begin
// fallback to RTL asm e.g. for ARM
{$ifdef STRCNT32}
result := InterLockedDecrement(refcnt) <= 0;
{$else}
result := InterLockedDecrement64(refcnt) <= 0;
{$endif STRCNT32}
end; // we don't check for ismultithread global
function DACntDecFree(var refcnt: TDACnt): boolean;
begin
// fallback to RTL asm e.g. for ARM
{$ifdef DACNT32}
result := InterLockedDecrement(refcnt) <= 0;
{$else}
result := InterLockedDecrement64(refcnt) <= 0;
{$endif DACNT32}
end;
procedure LockedInc32(int32: PInteger);
begin
InterlockedIncrement(int32^);
end;
procedure LockedDec32(int32: PInteger);
begin
InterlockedDecrement(int32^);
end;
procedure LockedInc64(int64: PInt64);
begin
{$ifdef FPC_64}
InterlockedIncrement64(int64^); // we can use the existing 64-bit RTL function
{$else}
with PInt64Rec(int64)^ do
if InterlockedIncrement(Lo) = 0 then
InterlockedIncrement(Hi); // collission is highly unprobable
{$endif FPC_64}
end;
function LockedExc(var Target: PtrUInt; NewValue, Comperand: PtrUInt): boolean;
begin
result := InterlockedCompareExchange(
pointer(Target), pointer(NewValue), pointer(Comperand)) = pointer(Comperand);
end;
procedure LockedAdd(var Target: PtrUInt; Increment: PtrUInt);
begin
InterlockedExchangeAdd(pointer(Target), pointer(Increment));
end;
procedure LockedAdd32(var Target: cardinal; Increment: cardinal);
begin
InterlockedExchangeAdd(Target, Increment);
end;
procedure LockedDec(var Target: PtrUInt; Decrement: PtrUInt);
begin
InterlockedExchangeAdd(pointer(Target), pointer(-PtrInt(Decrement)));
end;
procedure bswap64array(a,b: PQWordArray; n: PtrInt);
var
i: PtrInt;
begin
for i := 0 to n - 1 do
b^[i] := {$ifdef FPC}SwapEndian{$else}bswap64{$endif}(a^[i]);
end;
function bswap32(a: cardinal): cardinal;
begin
result := SwapEndian(a); // use fast platform-specific function
end;
function bswap64(const a: QWord): QWord;
begin
result := SwapEndian(a); // use fast platform-specific function
end;
function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: byte): PtrInt;
begin
result := IndexByte(P^, Count, Value); // use FPC RTL
end;
function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt;
begin
result := IndexWord(P^, Count, Value); // use FPC RTL
end;
function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal;
begin
result := nil;
if P = nil then
exit;
Count := PtrUInt(@P[Count - 4]); // per-four loop is faster than FPC RTL
repeat
if PtrUInt(P) > PtrUInt(Count) then
break;
if P^[0] <> Value then
if P^[1] <> Value then
if P^[2] <> Value then
if P^[3] <> Value then
begin
P := @P[4];
continue;
end
else
result := @P[3]
else
result := @P[2]
else
result := @P[1]
else
result := pointer(P);
exit;
until false;
inc(Count, 4 * SizeOf(Value));
result := pointer(P);
repeat
if PtrUInt(result) >= PtrUInt(Count) then
break;
if result^ = Value then
exit;
inc(result);
until false;
result := nil;
end;
function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean;
begin
if P <> nil then
begin
result := true;
Count := PtrInt(@P[Count - 4]);
repeat
if PtrUInt(P) > PtrUInt(Count) then
break;
if (P^[0] = Value) or
(P^[1] = Value) or
(P^[2] = Value) or
(P^[3] = Value) then
exit;
P := @P[4];
until false;
inc(Count, 4 * SizeOf(Value));
repeat
if PtrUInt(P) >= PtrUInt(Count) then
break;
if P^[0] = Value then
exit;
P := @P[1];
until false;
end;
result := false;
end;
function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt;
begin
result := PtrUInt(IntegerScan(P, Count, Value));
if result = 0 then
dec(result)
else
begin
dec(result, PtrUInt(P));
result := result shr 2;
end;
end;
{$ifdef CPUARM3264} // ARM-specific code
{$ifdef OSLINUXANDROID} // read CpuFeatures from Linux envp
const
AT_HWCAP = 16;
AT_HWCAP2 = 26;
procedure TestCpuFeatures;
var
p: PPChar;
caps: TArmHwCaps;
begin
// C library function getauxval() is not always available -> use system.envp
caps := [];
try
p := system.envp;
while p^ <> nil do
inc(p);
inc(p); // auxv is located after the last textual environment variable
repeat
if PtrUInt(p[0]) = AT_HWCAP then // 32-bit or 64-bit entries = PtrUInt
PCardinalArray(@caps)[0] := PtrUInt(p[1])
else if PtrUInt(p[0]) = AT_HWCAP2 then
PCardinalArray(@caps)[1] := PtrUInt(p[1]);
p := @p[2];
until p[0] = nil;
except
// may happen on some untested Operating System
caps := []; // is likely to be invalid
end;
CpuFeatures := caps;
end;
{$else}
procedure TestCpuFeatures;
begin
// perhaps system.envp would work somewhat, but the HWCAP items don't match
end;
{$endif OSLINUXANDROID}
function HasHWAes: boolean;
begin
result := ahcAES in CpuFeatures;
end;
{$else} // non Intel nor ARM CPUs
procedure TestCpuFeatures;
begin
end;
function HasHWAes: boolean;
begin
result := false;
end;
{$endif CPUARM3264}
{$endif CPUINTEL}
{$ifndef ASMINTEL}
// fallback to pure pascal version for ARM or Intel PIC
function crc32fasttab(crc: cardinal; buf: PAnsiChar; len: cardinal;
tab: PCrc32tab): cardinal; inline;
begin
// on ARM, we use slicing-by-4 to avoid polluting smaller L1 cache
result := not crc;
if (buf <> nil) and
(len > 0) then
begin
repeat
if PtrUInt(buf) and 3 = 0 then // align to 4 bytes boundary
break;
result := tab[0, ToByte(result xor ord(buf^))] xor (result shr 8);
dec(len);
inc(buf);
until len = 0;
if len >= 4 then
repeat
result := result xor PCardinal(buf)^;
inc(buf, 4);
dec(len, 4);
result := tab[3, ToByte(result)] xor tab[2, ToByte(result shr 8)] xor
tab[1, ToByte(result shr 16)] xor tab[0, ToByte(result shr 24)];
until len < 4;
while len > 0 do
begin
result := tab[0, ToByte(result xor ord(buf^))] xor (result shr 8);
dec(len);
inc(buf);
end;
end;
result := not result;
end;
function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar;
begin
if val < 0 then
begin
result := StrUInt32(P, PtrUInt(-val)) - 1;
result^ := '-';
end
else
result := StrUInt32(P, val);
end;
function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar;
var
c100: PtrUInt; // val/c100 are QWord on 64-bit CPU
tab: PWordArray;
begin
// this code is faster than Borland's original str() or IntToStr()
tab := @TwoDigitLookupW;
repeat
if val < 10 then
begin
dec(P);
P^ := AnsiChar(val + ord('0'));
break;
end
else if val < 100 then
begin
dec(P, 2);
PWord(P)^ := tab[val];
break;
end;
dec(P, 2);
c100 := val div 100; // FPC will use fast reciprocal
dec(val, c100 * 100);
PWord(P)^ := tab[val];
val := c100;
if c100 = 0 then
break;
until false;
result := P;
end;
{$endif ASMINTEL}
{ ************ Buffers (e.g. Hashing and SynLZ compression) Raw Functions }
{$ifndef CPUX64} // there is fast branchless SSE2 assembly on x86-64
function BufferLineLength(Text, TextEnd: PUtf8Char): PtrInt;
var
c: byte;
begin
result := PtrUInt(Text) - 1;
repeat
inc(result);
if PtrUInt(result) < PtrUInt(TextEnd) then
begin
c := PByte(result)^;
if (c > 13) or
((c <> 10) and
(c <> 13)) then
continue;
end;
break;
until false;
dec(result, PtrInt(Text)); // returns length
end;
function PosChar(Str: PUtf8Char; Chr: AnsiChar): PUtf8Char;
var
c: AnsiChar;
begin
result := nil;
if Str = nil then
exit;
repeat
c := Str^;
if c = #0 then
exit
else if c = Chr then
break;
inc(Str);
until false;
result := Str;
end;
function MemCmp(P1, P2: PByteArray; L: PtrInt): integer;
begin
// caller ensured that P1<>nil, P2<>nil and L>0 -> aggressively inlined asm
result := 0;
if L <= 0 then
exit;
inc(PtrUInt(P1), PtrUInt(L));
inc(PtrUInt(P2), PtrUInt(L));
L := -L;
repeat
if P1[L] <> P2[L] then
break;
inc(L);
if L <> 0 then
continue;
exit;
until false;
result := P1[L] - P2[L];
end;
{$endif CPUX64}
function SynLZcompressdestlen(in_len: integer): integer;
begin
// get maximum possible (worse) compressed size for out_p
result := in_len + in_len shr 3 + 16;
end;
function SynLZdecompressdestlen(in_p: PAnsiChar): integer;
begin
// get uncompressed size from lz-compressed buffer (to reserve memory, e.g.)
result := PWord(in_p)^;
if result and $8000 <> 0 then
result := (result and $7fff) or (integer(PWord(in_p + 2)^) shl 15);
end;
function SynLZcompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
var
dst_beg, // initial dst value
src_end, // real last byte available in src
src_endmatch, // last byte to try for hashing
o: PAnsiChar;
CWbit: byte;
CWpoint: PCardinal;
v, h, cached, t, tmax: PtrUInt;
offset: TOffsets;
cache: array[0..4095] of cardinal; // 16KB+16KB=32KB on stack (48KB for cpu64)
begin
dst_beg := dst;
// 1. store in_len
if size >= $8000 then
begin
// size in 32KB..2GB -> stored as integer
PWord(dst)^ := $8000 or (size and $7fff);
PWord(dst + 2)^ := size shr 15;
inc(dst, 4);
end
else
begin
PWord(dst)^ := size; // size<32768 -> stored as word
if size = 0 then
begin
result := 2;
exit;
end;
inc(dst, 2);
end;
// 2. compress
src_end := src + size;
src_endmatch := src_end - (6 + 5);
CWbit := 0;
CWpoint := pointer(dst);
PCardinal(dst)^ := 0;
inc(dst, SizeOf(CWpoint^));
FillCharFast(offset, SizeOf(offset), 0); // fast 16KB reset to 0
// 1. main loop to search using hash[]
if src <= src_endmatch then
repeat
v := PCardinal(src)^;
h := ((v shr 12) xor v) and 4095;
o := offset[h];
offset[h] := src;
cached := v xor {%H-}cache[h]; // o=nil if cache[h] is uninitialized
cache[h] := v;
if (cached and $00ffffff = 0) and
(o <> nil) and
(src - o > 2) then
begin
CWpoint^ := CWpoint^ or (cardinal(1) shl CWbit);
inc(src, 2);
inc(o, 2);
t := 1;
tmax := src_end - src - 1;
if tmax >= (255 + 16) then
tmax := (255 + 16);
while (o[t] = src[t]) and
(t < tmax) do
inc(t);
inc(src, t);
h := h shl 4;
// here we have always t>0
if t <= 15 then
begin
// mark 2 to 17 bytes -> size=1..15
PWord(dst)^ := integer(t or h);
inc(dst, 2);
end
else
begin
// mark 18 to (255+16) bytes -> size=0, next byte=t
dec(t, 16);
PWord(dst)^ := h; // size=0
dst[2] := ansichar(t);
inc(dst, 3);
end;
end
else
begin
dst^ := src^;
inc(src);
inc(dst);
end;
if CWbit < 31 then
begin
inc(CWbit);
if src <= src_endmatch then
continue
else
break;
end
else
begin
CWpoint := pointer(dst);
PCardinal(dst)^ := 0;
inc(dst, SizeOf(CWpoint^));
CWbit := 0;
if src <= src_endmatch then
continue
else
break;
end;
until false;
// 2. store remaining bytes
if src < src_end then
repeat
dst^ := src^;
inc(src);
inc(dst);
if CWbit < 31 then
begin
inc(CWbit);
if src < src_end then
continue
else
break;
end
else
begin
PCardinal(dst)^ := 0;
inc(dst, 4);
CWbit := 0;
if src < src_end then
continue
else
break;
end;
until false;
result := dst - dst_beg;
end;
// better code generation with sub-functions for raw decoding
procedure SynLZdecompress1passub(src, src_end, dst: PAnsiChar; var offset: TOffsets);
var
last_hashed: PAnsiChar; // initial src and dst value
{$ifdef CPU64}
o: PAnsiChar;
{$endif CPU64}
CW, CWbit: cardinal;
v, t, h: PtrUInt;
label
nextCW;
begin
last_hashed := dst - 1;
nextCW:
CW := PCardinal(src)^;
inc(src, 4);
CWbit := 1;
if src < src_end then
repeat
if CW and CWbit = 0 then
begin
dst^ := src^;
inc(src);
inc(dst);
if src >= src_end then
break;
if last_hashed < dst - 3 then
begin
inc(last_hashed);
v := PCardinal(last_hashed)^;
offset[((v shr 12) xor v) and 4095] := last_hashed;
end;
CWbit := CWbit shl 1;
if CWbit <> 0 then
continue
else
goto nextCW;
end
else
begin
h := PWord(src)^;
inc(src, 2);
t := (h and 15) + 2;
if t = 2 then
begin
t := ord(src^) + (16 + 2);
inc(src);
end;
h := h shr 4;
{$ifdef CPU64}
o := offset[h];
if PtrUInt(dst - o) < t then // overlap -> move byte-by-byte
MoveByOne(o, dst, t)
else if t <= 8 then
PInt64(dst)^ := PInt64(o)^ // much faster in practice
else
MoveFast(o^, dst^, t); // safe since src_endmatch := src_end-(6+5)
{$else}
if PtrUInt(dst - offset[h]) < t then
MoveByOne(offset[h], dst, t)
else if t > 8 then
MoveFast(offset[h]^, dst^, t)
else
PInt64(dst)^ := PInt64(offset[h])^;
{$endif CPU64}
if src >= src_end then
break;
if last_hashed < dst then
repeat // decompressed bytes should update the hash table
inc(last_hashed);
v := PCardinal(last_hashed)^;
offset[((v shr 12) xor v) and 4095] := last_hashed;
until last_hashed >= dst;
inc(dst, t);
last_hashed := dst - 1;
CWbit := CWbit shl 1;
if CWbit <> 0 then
continue
else
goto nextCW;
end;
until false;
end;
function SynLZdecompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
var
offset: TOffsets;
src_end: PAnsiChar;
begin
src_end := src + size;
result := PWord(src)^;
if result = 0 then
exit;
inc(src, 2);
if result and $8000 <> 0 then
begin
result := (result and $7fff) or (integer(PWord(src)^) shl 15);
inc(src, 2);
end;
SynLZdecompress1passub(src, src_end, dst, offset);
end;
procedure SynLZdecompress1partialsub(src, dst, src_end, dst_end: PAnsiChar;
var offset: TOffsets);
var
last_hashed: PAnsiChar; // initial src and dst value
CWbit, CW: integer;
v, t, h: PtrUInt;
{$ifdef CPU64}
o: PAnsiChar;
{$endif CPU64}
label
nextCW;
begin
last_hashed := dst - 1;
nextCW:
CW := PCardinal(src)^;
inc(src, 4);
CWbit := 1;
if src < src_end then
repeat
if CW and CWbit = 0 then
begin
dst^ := src^;
inc(src);
inc(dst);
if (src >= src_end) or
(dst >= dst_end) then
break;
if last_hashed < dst - 3 then
begin
inc(last_hashed);
v := PCardinal(last_hashed)^;
offset[((v shr 12) xor v) and 4095] := last_hashed;
end;
CWbit := CWbit shl 1;
if CWbit <> 0 then
continue
else
goto nextCW;
end
else
begin
h := PWord(src)^;
inc(src, 2);
t := (h and 15) + 2;
h := h shr 4;
if t = 2 then
begin
t := ord(src^) + (16 + 2);
inc(src);
end;
if dst + t >= dst_end then
begin
// avoid buffer overflow by all means
MoveByOne(offset[h], dst, dst_end - dst);
break;
end;
{$ifdef CPU64}
o := offset[h];
if (t <= 8) or
(PtrUInt(dst - o) < t) then
MoveByOne(o, dst, t)
else
MoveFast(o^, dst^, t);
{$else}
if (t <= 8) or
(PtrUInt(dst - offset[h]) < t) then
MoveByOne(offset[h], dst, t)
else
MoveFast(offset[h]^, dst^, t);
{$endif CPU64}
if src >= src_end then
break;
if last_hashed < dst then
repeat
inc(last_hashed);
v := PCardinal(last_hashed)^;
offset[((v shr 12) xor v) and 4095] := last_hashed;
until last_hashed >= dst;
inc(dst, t);
last_hashed := dst - 1;
CWbit := CWbit shl 1;
if CWbit <> 0 then
continue
else
goto nextCW;
end;
until false;
end;
function SynLZdecompress1partial(src: PAnsiChar; size: integer; dst: PAnsiChar;
maxDst: integer): integer;
var
offset: TOffsets;
src_end: PAnsiChar;
begin
src_end := src + size;
result := PWord(src)^;
if result = 0 then
exit;
inc(src, 2);
if result and $8000 <> 0 then
begin
result := (result and $7fff) or (integer(PWord(src)^) shl 15);
inc(src, 2);
end;
if maxDst < result then
result := maxDst;
if result > 0 then
SynLZdecompress1partialsub(src, dst, src_end, dst + result, offset);
end;
function CompressSynLZ(var Data: RawByteString; Compress: boolean): RawUtf8;
var
DataLen, len: integer;
P: PAnsiChar;
tmp: TSynTempBuffer;
begin
DataLen := length(Data);
if DataLen <> 0 then // '' is compressed and uncompressed to ''
if Compress then
begin
len := SynLZcompressdestlen(DataLen) + 8;
P := tmp.Init(len);
PCardinal(P)^ := Hash32(pointer(Data), DataLen);
len := SynLZcompress1(pointer(Data), DataLen, P + 8);
PCardinal(P + 4)^ := Hash32(pointer(P + 8), len);
FastSetRawByteString(Data, P, len + 8);
{%H-}tmp.Done;
end
else
begin
result := '';
P := pointer(Data);
if (DataLen <= 8) or
(Hash32(pointer(P + 8), DataLen - 8) <> PCardinal(P + 4)^) then
exit;
len := SynLZdecompressdestlen(P + 8);
tmp.Init(len);
if (len = 0) or
((SynLZDecompress1(P + 8, DataLen - 8, tmp.buf) = len) and
(Hash32(tmp.buf, len) = PCardinal(P)^)) then
FastSetRawByteString(Data, tmp.buf, len);
{%H-}tmp.Done;
end;
result := 'synlz';
end;
function CompressSynLZGetHash32(const Data: RawByteString): cardinal;
var
DataLen: integer;
P: PAnsiChar;
begin
DataLen := length(Data);
P := pointer(Data);
if (DataLen <= 8) or
(Hash32(pointer(P + 8), DataLen - 8) <> PCardinal(P + 4)^) then
result := 0
else
result := PCardinal(P)^;
end;
const
RLE_CW = $5a; // any byte would do - this one is nothing special but for me
function RleEncode(dst: PByteArray; v, n: PtrUInt): PByteArray;
{$ifdef HASINLINE} inline; {$endif}
begin
if (n > 3) or
(v = RLE_CW) then // encode as dst[0]=RLE_CW dst[1]=count dst[2]=value
begin
v := v shl 16;
inc(v, RLE_CW);
while n > 255 do
begin
PCardinal(dst)^ := v + 255 shl 8;
dst := @dst[3];
dec(n, 255);
end;
inc(v, n shl 8);
result := @dst[3];
end
else
begin
inc(v, (v shl 8) + (v shl 16)); // append the value n (=1,2,3) times
result := @dst[n]; // seems faster with branchless move
end;
PCardinal(dst)^ := v;
end;
function RleCompress(src, dst: PByteArray; srcsize, dstsize: PtrUInt): PtrInt;
var
dststart: PAnsiChar;
c, b, n: PtrUInt;
begin
dststart := PAnsiChar(dst);
if srcsize <> 0 then
begin
dstsize := PtrUInt(@dst[dstsize - 3]); // pointer(dstsize) = dstmax
b := src[0];
n := 0;
repeat
c := src[0];
inc(PByte(src));
if c = b then
begin
inc(n);
dec(srcsize);
if (srcsize = 0) or
(PtrUInt(dst) >= PtrUInt(dstsize)) then
break;
end
else // dedicated if n = 1 then .. branch was slower
begin
dst := RleEncode(dst, b, n);
n := 1;
b := c;
dec(srcsize);
if (srcsize = 0) or
(PtrUInt(dst) >= PtrUInt(dstsize)) then
break;
end;
until false;
dst := RleEncode(dst, b, n);
if PtrUInt(dst) >= PtrUInt(dstsize) then
begin
result := -1;
exit;
end;
end;
result := PAnsiChar(dst) - dststart;
end;
{$ifdef CPUINTEL}
{$ifndef HASNOSSE2}
{$define INLINEDSEARCH} // leverage ByteScanIndex() SSE2 asm
{$endif HASNOSSE2}
{$endif CPUINTEL}
{.$define INLINEDFILL} // actually slower
function RleUnCompress(src, dst: PByteArray; size: PtrUInt): PtrUInt;
var
dststart: PAnsiChar;
{$ifdef INLINEDFILL}
c: PtrInt;
{$endif INLINEDFILL}
v: PtrUInt;
begin
dststart := PAnsiChar(dst);
if size > 0 then
repeat
{$ifdef INLINEDSEARCH}
if src[0] <> RLE_CW then
begin
v := ByteScanIndex(src, size, RLE_CW);
if PtrInt(v) < 0 then
v := size;
MoveFast(src^, dst^, v);
inc(PByte(src), v);
inc(PByte(dst), v);
dec(size, v);
if size = 0 then
break;
end;
{$else}
v := src[0];
if v <> RLE_CW then
begin
dst[0] := v;
inc(PByte(dst));
inc(PByte(src));
dec(size);
if size = 0 then
break;
end
else
{$endif INLINEDSEARCH}
begin // here src[0]=RLE_CW src[1]=count src[2]=value
{$ifdef INLINEDFILL}
c := src[1];
v := src[2];
inc(PByte(dst), c);
c := -c;
repeat
dst[c] := v;
inc(c);
until c = 0;
{$else}
v := src[1];
FillCharFast(dst^, v, src[2]);
inc(PByte(dst), v);
{$endif INLINEDFILL}
inc(PByte(src), 3);
dec(size, 3);
if PtrInt(size) <= 0 then
break;
end
until false;
result := PAnsiChar(dst) - dststart;
end;
function RleUnCompressPartial(src, dst: PByteArray; size, max: PtrUInt): PtrUInt;
var
dststart: PAnsiChar;
v, m: PtrUInt;
begin
dststart := PAnsiChar(dst);
inc(max, PtrUInt(dst));
while (size > 0) and
(PtrUInt(dst) < max) do
begin
v := src[0];
if v = RLE_CW then
begin
v := src[1];
m := max - PtrUInt(dst);
if v > m then
v := m; // compile as cmov on FPC
FillCharFast(dst^, v, src[2]);
inc(PByte(dst), v);
inc(PByte(src), 3);
dec(size, 3);
end
else
begin
dst[0] := v;
inc(PByte(dst));
inc(PByte(src));
dec(size);
end;
end;
result := PAnsiChar(dst) - dststart;
end;
{ TSynTempBuffer }
procedure TSynTempBuffer.Init(Source: pointer; SourceLen: PtrInt);
begin
len := SourceLen;
if SourceLen <= 0 then
buf := nil
else
begin
if SourceLen <= SizeOf(tmp) - 16 then // max internal tmp is 4080 bytes
buf := @tmp
else
GetMem(buf, SourceLen + 16); // +16 for trailing #0 and for PInteger() parsing
if Source <> nil then
begin
MoveFast(Source^, buf^, len);
PPtrInt(PAnsiChar(buf) + len)^ := 0; // init last 4/8 bytes (for valgrid)
end;
end;
end;
function TSynTempBuffer.InitOnStack: pointer;
begin
buf := @tmp;
len := SizeOf(tmp);
result := @tmp;
end;
procedure TSynTempBuffer.Init(const Source: RawByteString);
begin
Init(pointer(Source), length(Source));
end;
function TSynTempBuffer.Init(Source: PUtf8Char): PUtf8Char;
begin
Init(Source, StrLen(Source));
result := buf;
end;
function TSynTempBuffer.Init(SourceLen: PtrInt): pointer;
begin
len := SourceLen;
if SourceLen <= 0 then
buf := nil
else
begin
if SourceLen <= SizeOf(tmp) - 16 then // max internal tmp is 4080 bytes
buf := @tmp
else
GetMem(buf, SourceLen + 16); // +16 for trailing #0 and buffer overflow
PPtrInt(PAnsiChar(buf) + SourceLen)^ := 0; // init last 4/8 bytes
end;
result := buf;
end;
function TSynTempBuffer.Init: integer;
begin
buf := @tmp;
result := SizeOf(tmp) - 16; // set to maximum safe size, which is 4080 bytes
len := result;
end;
function TSynTempBuffer.InitRandom(RandomLen: integer): pointer;
begin
Init(RandomLen);
RandomBytes(buf, RandomLen);
result := buf;
end;
function TSynTempBuffer.InitIncreasing(Count, Start: PtrInt): PIntegerArray;
begin
Init((Count - Start) * 4);
FillIncreasing(buf, Start, Count);
result := buf;
end;
function TSynTempBuffer.InitZero(ZeroLen: PtrInt): pointer;
begin
if ZeroLen = 0 then
ZeroLen := SizeOf(tmp) - 16;
Init(ZeroLen);
FillCharFast(buf^, ZeroLen, 0);
result := buf;
end;
function TSynTempBuffer.BufEnd: pointer;
begin
result := PAnsiChar(buf) + len;
end;
procedure TSynTempBuffer.Done;
begin
if (buf <> @tmp) and
(buf <> nil) then
FreeMem(buf);
end;
procedure TSynTempBuffer.Done(EndBuf: pointer; var Dest: RawUtf8);
begin
if EndBuf = nil then
Dest := ''
else
FastSetString(Dest, buf, PAnsiChar(EndBuf) - PAnsiChar(buf));
if (buf <> @tmp) and
(buf <> nil) then
FreeMem(buf);
end;
procedure OrMemory(Dest, Source: PByteArray; size: PtrInt);
begin
while size >= SizeOf(PtrInt) do
begin
dec(size, SizeOf(PtrInt));
PPtrInt(Dest)^ := PPtrInt(Dest)^ or PPtrInt(Source)^;
inc(PPtrInt(Dest));
inc(PPtrInt(Source));
end;
while size > 0 do
begin
dec(size);
Dest[size] := Dest[size] or Source[size];
end;
end;
procedure XorMemory(Dest, Source: PByteArray; size: PtrInt);
begin
while size >= SizeOf(PtrInt) do
begin
dec(size, SizeOf(PtrInt));
PPtrInt(Dest)^ := PPtrInt(Dest)^ xor PPtrInt(Source)^;
inc(PPtrInt(Dest));
inc(PPtrInt(Source));
end;
while size > 0 do
begin
dec(size);
Dest[size] := Dest[size] xor Source[size];
end;
end;
procedure XorMemory(Dest, Source1, Source2: PByteArray; size: PtrInt);
begin
while size >= SizeOf(PtrInt) do
begin
dec(size, SizeOf(PtrInt));
PPtrInt(Dest)^ := PPtrInt(Source1)^ xor PPtrInt(Source2)^;
inc(PPtrInt(Dest));
inc(PPtrInt(Source1));
inc(PPtrInt(Source2));
end;
while size > 0 do
begin
dec(size);
Dest[size] := Source1[size] xor Source2[size];
end;
end;
procedure AndMemory(Dest, Source: PByteArray; size: PtrInt);
begin
while size >= SizeOf(PtrInt) do
begin
dec(size, SizeOf(PtrInt));
PPtrInt(Dest)^ := PPtrInt(Dest)^ and PPtrInt(Source)^;
inc(PPtrInt(Dest));
inc(PPtrInt(Source));
end;
while size > 0 do
begin
dec(size);
Dest[size] := Dest[size] and Source[size];
end;
end;
function IsZero(P: pointer; Length: integer): boolean;
var
n: integer;
begin
result := false;
n := Length shr 4;
if n <> 0 then
repeat // 16 bytes (4 DWORD) by loop - aligned read
{$ifdef CPU64}
if (PInt64(P)^ <> 0) or
(PInt64Array(P)^[1] <> 0) then
{$else}
if (PCardinal(P)^ <> 0) or
(PCardinalArray(P)^[1] <> 0) or
(PCardinalArray(P)^[2] <> 0) or
(PCardinalArray(P)^[3] <> 0) then
{$endif CPU64}
exit
else
inc(PByte(P), 16);
dec(n);
until n = 0;
n := (Length shr 2) and 3;
if n <> 0 then
repeat // 4 bytes (1 DWORD) by loop
if PCardinal(P)^ <> 0 then
exit
else
inc(PByte(P), 4);
dec(n);
until n = 0;
n := Length and 3;
if n <> 0 then
repeat // remaining content
if PByte(P)^ <> 0 then
exit
else
inc(PByte(P));
dec(n);
until n = 0;
result := true;
end;
function IsZeroSmall(P: pointer; Length: PtrInt): boolean;
begin
result := false;
inc(PtrUInt(P), PtrUInt(Length));
Length := -Length;
repeat
if PByteArray(P)[Length] <> 0 then
exit;
inc(Length);
until Length = 0;
result := true;
end;
function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
begin
result := crc32fasttab(crc, buf, len, @crc32ctab);
end;
function crc32fast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
begin
result := crc32fasttab(crc, buf, len, @crc32tab);
end;
function crc32cBy4fast(crc, value: cardinal): cardinal;
var
tab: PCrc32tab;
begin
tab := @crc32ctab;
result := crc xor value;
result := tab[3, ToByte(result)] xor tab[2, ToByte(result shr 8)] xor
tab[1, ToByte(result shr 16)] xor tab[0, ToByte(result shr 24)];
end;
{$ifdef HASINLINE}
function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
var
tab: PCrc32tab;
begin
result := not crc;
tab := @crc32ctab;
if len > 0 then
repeat
result := tab[0, ToByte(result xor ord(buf^))] xor (result shr 8);
inc(buf);
dec(len);
until len = 0;
result := not result;
end;
{$else}
function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
begin
result := crc32c(crc, buf, len);
end;
{$endif HASINLINE}
function crc64c(buf: PAnsiChar; len: cardinal): Int64;
var
lo: PtrInt;
begin
lo := crc32c(0, buf, len);
result := Int64(lo) or (Int64(crc32c(lo, buf, len)) shl 32);
end;
function crc32cTwice(seed: QWord; buf: PAnsiChar; len: cardinal): QWord;
begin
PQWordRec(@result)^.L := crc32c(PQWordRec(@seed)^.L, buf, len);
PQWordRec(@result)^.H := crc32c(PQWordRec(@seed)^.H, buf, len);
end;
function crc63c(buf: PAnsiChar; len: cardinal): Int64;
var
lo: PtrInt;
begin
lo := crc32c(0, buf, len);
result := Int64(lo) or (Int64(crc32c(lo, buf, len) and $7fffffff) shl 32);
end;
procedure crc128c(buf: PAnsiChar; len: cardinal; out crc: THash128);
var
h: THash128Rec absolute crc;
h1, h2: cardinal;
begin
// see https://goo.gl/Pls5wi
h1 := crc32c(0, buf, len);
h2 := crc32c(h1, buf, len);
h.i0 := h1;
inc(h1, h2);
h.i1 := h1;
inc(h1, h2);
h.i2 := h1;
inc(h1, h2);
h.i3 := h1;
end;
procedure crc256c(buf: PAnsiChar; len: cardinal; out crc: THash256);
var
h: THash256Rec absolute crc;
h1, h2: cardinal;
begin
// see https://goo.gl/Pls5wi
h1 := crc32c(0, buf, len);
h2 := crc32c(h1, buf, len);
h.i0 := h1;
inc(h1, h2);
h.i1 := h1;
inc(h1, h2);
h.i2 := h1;
inc(h1, h2);
h.i3 := h1;
inc(h1, h2);
h.i4 := h1;
inc(h1, h2);
h.i5 := h1;
inc(h1, h2);
h.i6 := h1;
inc(h1, h2);
h.i7 := h1;
end;
procedure crc32c128(hash: PHash128; buf: PAnsiChar; len: cardinal);
var
blocks: cardinal;
begin
blocks := len shr 4;
if blocks <> 0 then
begin
crcblocks(pointer(hash), pointer(buf), blocks);
blocks := blocks shl 4;
inc(buf, blocks);
dec(len, blocks);
end;
if len <> 0 then
with PHash128Rec(hash)^ do
begin
c0 := crc32c(c0, buf, len);
c1 := crc32c(c1, buf, len);
c2 := crc32c(c2, buf, len);
c3 := crc32c(c3, buf, len);
end;
end;
function crc16(Data: PAnsiChar; Len: integer): cardinal;
var
i, j: integer;
begin
result := $ffff;
for i := 0 to Len - 1 do
begin
result := result xor (ord(Data[i]) shl 8);
for j := 1 to 8 do
if result and $8000 <> 0 then
result := (result shl 1) xor $1021
else
result := result shl 1;
end;
result := result and $ffff;
end;
function Hash32(const Text: RawByteString): cardinal;
begin
result := Hash32(pointer(Text), Length(Text));
end;
function DefaultHash(const s: RawByteString): cardinal;
begin
result := DefaultHasher(0, pointer(s), length(s));
end;
function DefaultHash(const b: TBytes): cardinal;
begin
result := DefaultHasher(0, pointer(b), length(b));
end;
function crc32cHash(const s: RawByteString): cardinal;
begin
result := crc32c(0, pointer(s), length(s));
end;
function crc32cHash(const b: TBytes): cardinal;
begin
result := crc32c(0, pointer(b), length(b));
end;
function Hash128To64(const b: THash128): QWord;
begin
result := THash128Rec(b).L xor (THash128Rec(b).H * QWord(2685821657736338717));
end;
function xxHash32Mixup(crc: cardinal): cardinal;
begin
result := crc;
result := result xor (result shr 15);
result := result * 2246822519;
result := result xor (result shr 13);
result := result * 3266489917;
result := result xor (result shr 16);
end;
procedure crcblockone(crc128, data128: PBlock128; tab: PCrc32tab);
{$ifdef HASINLINE} inline; {$endif}
var
c: cardinal;
begin
c := crc128^[0] xor data128^[0];
crc128^[0] := tab[3, ToByte(c)] xor tab[2, ToByte(c shr 8)] xor
tab[1, ToByte(c shr 16)] xor tab[0, ToByte(c shr 24)];
c := crc128^[1] xor data128^[1];
crc128^[1] := tab[3, ToByte(c)] xor tab[2, ToByte(c shr 8)] xor
tab[1, ToByte(c shr 16)] xor tab[0, ToByte(c shr 24)];
c := crc128^[2] xor data128^[2];
crc128^[2] := tab[3, ToByte(c)] xor tab[2, ToByte(c shr 8)] xor
tab[1, ToByte(c shr 16)] xor tab[0, ToByte(c shr 24)];
c := crc128^[3] xor data128^[3];
crc128^[3] := tab[3, ToByte(c)] xor tab[2, ToByte(c shr 8)] xor
tab[1, ToByte(c shr 16)] xor tab[0, ToByte(c shr 24)];
end;
{$ifndef ASMX86} // those functions have their tuned x86 asm version
{$ifdef CPUX64}
function CompareMem(P1, P2: Pointer; Length: PtrInt): boolean;
begin
result := MemCmp(P1, P2, Length) = 0; // use our SSE2 optimized asm
end;
{$else}
function CompareMem(P1, P2: Pointer; Length: PtrInt): boolean;
label
zero;
begin
// this awfull code compiles well under FPC and Delphi on 32-bit and 64-bit
Length := PtrInt(@PAnsiChar(P1)[Length - SizeOf(PtrInt) * 2]); // = 2*PtrInt end
if Length >= PtrInt(PtrUInt(P1)) then
begin
if PPtrInt(PtrUInt(P1))^ <> PPtrInt(P2)^ then // compare first PtrInt bytes
goto zero;
inc(PPtrInt(P1));
inc(PPtrInt(P2));
dec(PtrInt(P2), PtrInt(PtrUInt(P1)));
PtrInt(PtrUInt(P1)) := PtrInt(PtrUInt(P1)) and - SizeOf(PtrInt); // align
inc(PtrInt(P2), PtrInt(PtrUInt(P1)));
if Length >= PtrInt(PtrUInt(P1)) then
repeat
// compare 4 aligned PtrInt per loop
if (PPtrInt(PtrUInt(P1))^ <> PPtrInt(P2)^) or
(PPtrIntArray(P1)[1] <> PPtrIntArray(P2)[1]) then
goto zero;
inc(PByte(P1), SizeOf(PtrInt) * 2);
inc(PByte(P2), SizeOf(PtrInt) * 2);
if Length < PtrInt(PtrUInt(P1)) then
break;
if (PPtrInt(PtrUInt(P1))^ <> PPtrInt(P2)^) or
(PPtrIntArray(P1)[1] <> PPtrIntArray(P2)[1]) then
goto zero;
inc(PByte(P1), SizeOf(PtrInt) * 2);
inc(PByte(P2), SizeOf(PtrInt) * 2);
until Length < PtrInt(PtrUInt(P1));
end;
dec(Length, PtrInt(PtrUInt(P1)) - SizeOf(PtrInt) * 2); // back to real length
if Length >= SizeOf(PtrInt) then
begin
if PPtrInt(PtrUInt(P1))^ <> PPtrInt(P2)^ then
goto zero;
inc(PPtrInt(P1));
inc(PPtrInt(P2));
dec(Length, SizeOf(PtrInt));
end;
{$ifdef CPU64}
if Length >= 4 then
begin
if PCardinal(P1)^ <> PCardinal(P2)^ then
goto zero;
inc(PCardinal(P1));
inc(PCardinal(P2));
dec(Length, 4);
end;
{$endif CPU64}
if Length >= 2 then
begin
if PWord(P1)^ <> PWord(P2)^ then
goto zero;
inc(PWord(P1));
inc(PWord(P2));
dec(Length, 2);
end;
if Length >= 1 then
if PByte(P1)^ <> PByte(P2)^ then
goto zero;
result := true;
exit;
zero:
result := false;
end;
{$endif CPUX64}
procedure crcblockfast(crc128, data128: PBlock128);
begin
crcblockone(crc128, data128, @crc32ctab);
end;
function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
var
i: PtrInt;
begin
if buf <> nil then
for i := 0 to len - 1 do
crc := (crc xor ord(buf[i])) * 16777619;
result := crc;
end;
function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
var
i: PtrInt;
begin
if buf <> nil then
for i := 0 to len - 1 do
begin
crc := crc * 31;
inc(crc, ord(buf[i]));
end;
result := crc;
end;
procedure YearToPChar(Y: PtrUInt; P: PUtf8Char);
var
d100: PtrUInt;
tab: PWordArray;
begin
tab := @TwoDigitLookupW;
d100 := Y div 100; // FPC will use fast reciprocal
PWordArray(P)[0] := tab[d100];
PWordArray(P)[1] := tab[Y - (d100 * 100)];
end;
{$endif ASMX86}
function CompareBuf(const P1: RawByteString; P2: Pointer; P2Len: PtrInt): integer;
begin
result := ComparePtrInt(length(P1), P2Len);
if result = 0 then
result := MemCmp(pointer(P1), P2, P2Len);
end;
function CompareBuf(const P1, P2: RawByteString): integer;
begin
result := SortDynArrayRawByteString(P1, P2);
end;
function EqualBuf(const P1, P2: RawByteString): boolean;
begin
result := SortDynArrayRawByteString(P1, P2) = 0;
end;
procedure crcblocksfast(crc128, data128: PBlock128; count: integer);
var
tab: PCrc32tab; // good enough or PIC or ARM
begin
if count <= 0 then
exit;
tab := @crc32ctab;
repeat
crcblockone(crc128, data128, tab); // properly inlined
inc(data128);
dec(count);
until count = 0;
end;
function SameValue(const A, B: Double; DoublePrec: double): boolean;
var
AbsA, AbsB, Res: double;
begin
if PInt64(@DoublePrec)^ = 0 then
begin
// Max(Min(Abs(A),Abs(B))*1E-12,1E-12)
AbsA := Abs(A);
AbsB := Abs(B);
Res := 1E-12;
if AbsA < AbsB then
DoublePrec := AbsA * Res
else
DoublePrec := AbsB * Res;
if DoublePrec < Res then
DoublePrec := Res;
end;
if A < B then
result := (B - A) <= DoublePrec
else
result := (A - B) <= DoublePrec;
end;
function SameValueFloat(const A, B: TSynExtended; DoublePrec: TSynExtended): boolean;
var
AbsA, AbsB, Res: TSynExtended;
begin
if DoublePrec = 0 then
begin
// Max(Min(Abs(A),Abs(B))*1E-12,1E-12)
AbsA := Abs(A);
AbsB := Abs(B);
Res := 1E-12; // also for TSynExtended (FPC uses 1E-4!)
if AbsA < AbsB then
DoublePrec := AbsA * Res
else
DoublePrec := AbsB * Res;
if DoublePrec < Res then
DoublePrec := Res;
end;
if A < B then
result := (B - A) <= DoublePrec
else
result := (A - B) <= DoublePrec;
end;
function CompareFloat(const A, B: double): integer;
begin
result := ord(A > B) - ord(A < B);
end;
procedure KahanSum(const Data: double; var Sum, Carry: double);
var
y, t: double;
begin
y := Data - Carry;
t := Sum + y;
Carry := (t - Sum) - y;
Sum := t;
end;
{ ************ Efficient Variant Values Conversion }
procedure SetVariantNull(var Value: variant);
begin
VarClearAndSetType(Value, varNull);
end;
procedure ClearVariantForString(var Value: variant);
var
v: cardinal;
begin
v := TVarData(Value).VType;
if v = varString then
FastAssignNew(TVarData(Value).VAny)
else
begin
VarClearAndSetType(Value, varString);
TVarData(Value).VAny := nil; // to avoid GPF when assigning the value
end;
end;
procedure RawByteStringToVariant(Data: PByte; DataLen: integer; var Value: variant);
begin
ClearVariantForString(Value);
if (Data = nil) or
(DataLen <= 0) then
PCardinal(@Value)^ := varNull
else
FastSetRawByteString(RawByteString(TVarData(Value).VAny), Data, DataLen);
end;
procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant);
begin
ClearVariantForString(Value);
if Data = '' then
PCardinal(@Value)^ := varNull
else
RawByteString(TVarData(Value).VAny) := Data;
end;
procedure VariantToUtf8(const Value: variant; var Dest: RawByteString);
begin // sub-proc to avoid hidden temp variable in VariantToRawByteString
Dest := {$ifdef UNICODE}RawByteString{$else}string{$endif}(Value);
end;
procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString);
begin
case integer(TVarData(Value).VType) of
varEmpty,
varNull:
Dest := '';
varString:
Dest := RawByteString(TVarData(Value).VAny);
varStringByRef:
Dest := PRawByteString(TVarData(Value).VAny)^;
varVariantByRef:
VariantToRawByteString(PVariant(TVarData(Value).VPointer)^, Dest);
else // not from RawByteStringToVariant() -> conversion to string
VariantToUtf8(Value, Dest);
end;
end;
function VarDataFromVariant(const Value: variant): PVarData;
begin
result := @Value;
repeat
if integer(result^.VType) <> varVariantByRef then
exit;
if result^.VPointer <> nil then
result := result^.VPointer
else
begin
result := @result^.VPointer; // so VType will point to 0=varEmpty
exit;
end;
until false;
end;
function VarDataIsEmptyOrNull(VarData: pointer): boolean;
begin
with VarDataFromVariant(PVariant(VarData)^)^ do
result := (cardinal(VType) <= varNull) or
(cardinal(VType) = varNull or varByRef);
end;
function VarIsEmptyOrNull(const V: Variant): boolean;
begin
with VarDataFromVariant(V)^ do
result := (cardinal(VType) <= varNull) or
(cardinal(VType) = varNull or varByRef);
end;
function SetVariantUnRefSimpleValue(const Source: variant;
var Dest: TVarData): boolean;
var
typ: cardinal;
begin
result := false;
typ := TVarData(Source).VType;
if typ and varByRef = 0 then
exit;
typ := typ and not varByRef;
case typ of
varVariant:
if integer(PVarData(TVarData(Source).VPointer)^.VType) in VTYPE_SIMPLE then
begin
Dest := PVarData(TVarData(Source).VPointer)^;
result := true;
end;
varEmpty..varDate,
varBoolean,
varShortInt..varWord64:
begin
PCardinal(@Dest)^ := typ;
Dest.VInt64 := PInt64(TVarData(Source).VAny)^;
result := true;
end;
end;
end;
function SetVarDataUnRefSimpleValue(V: PVarData; var tmp: TVarData): PVarData;
{$ifdef HASINLINE}inline;{$endif}
var
typ: cardinal;
begin
typ := V^.VType;
if typ and varByRef <> 0 then
begin
typ := typ and not varByRef;
if typ in VTYPE_SIMPLE then
begin
PCardinal(@tmp)^ := typ;
tmp.VInt64 := PInt64(V^.VAny)^;
result := @tmp;
exit;
end
end;
result := nil;
end;
function VariantToInteger(const V: Variant; var Value: integer): boolean;
var
vd: PVarData;
tmp: TVarData;
begin
result := false;
vd := VarDataFromVariant(V);
repeat
case cardinal(vd^.VType) of
varNull,
varEmpty:
Value := 0;
varBoolean:
if vd^.VBoolean then
Value := 1
else
Value := 0; // normalize
varSmallint:
Value := vd^.VSmallInt;
varShortInt:
Value := vd^.VShortInt;
varWord:
Value := vd^.VWord;
varLongWord,
varOleUInt:
if vd^.VLongWord <= cardinal(High(integer)) then
Value := vd^.VLongWord
else
exit;
varByte:
Value := vd^.VByte;
varInteger,
varOleInt:
Value := vd^.VInteger;
varWord64:
if (vd^.VInt64 >= 0) and
(vd^.VInt64 <= High(integer)) then
Value := vd^.VInt64
else
exit;
varInt64:
if (vd^.VInt64 >= Low(integer)) and
(vd^.VInt64 <= High(integer)) then
Value := vd^.VInt64
else
exit;
varDouble,
varDate,
varSingle,
varCurrency,
varString,
varOleStr:
exit;
else
begin
vd := SetVarDataUnRefSimpleValue(vd, tmp{%H-});
if vd <> nil then
continue; // avoid a goto
exit;
end;
end;
break;
until false;
result := true;
end;
function VariantToDouble(const V: Variant; var Value: double): boolean;
var
vd: PVarData;
i64: Int64;
begin
vd := VarDataFromVariant(V);
result := true;
case cardinal(vd^.VType) of
varEmpty,
varNull:
Value := 0;
varDouble,
varDate:
Value := vd^.VDouble;
varSingle:
Value := vd^.VSingle;
varCurrency:
CurrencyToDouble(@vd^.VCurrency, Value);
varDouble or varByRef,
varDate or varByRef:
Value := unaligned(PDouble(vd^.VAny)^);
varSingle or varByRef:
Value := {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}unaligned{$endif}(
PSingle(vd^.VAny)^);
varCurrency or varByRef:
CurrencyToDouble(vd^.VAny, Value);
else
if VariantToInt64(PVariant(vd)^, i64) then
Value := i64
else
result := false;
end;
end;
function VariantToDoubleDef(const V: Variant; const default: double = 0): double;
begin
if not VariantToDouble(V, result) then
result := default;
end;
function VariantToCurrency(const V: Variant; var Value: currency): boolean;
var
vd: PVarData;
tmp: TVarData;
begin
vd := VarDataFromVariant(V);
result := true;
case cardinal(vd^.VType) of
varDouble,
varDate:
DoubleToCurrency(vd^.VDouble, Value);
varSingle:
DoubleToCurrency(vd^.VSingle, Value);
varCurrency:
Value := PCurrency(@vd^.VCurrency)^;
varDouble or varByRef,
varDate or varByRef:
DoubleToCurrency(PDouble(vd^.VAny)^, Value);
varSingle or varByRef:
DoubleToCurrency(PSingle(vd^.VAny)^, Value);
varCurrency or varByRef:
Value := PCurrency(vd^.VAny)^;
else
if VariantToInt64(PVariant(vd)^, tmp.VInt64) then
Int64ToCurrency(tmp.VInt64, Value) // also handle varEmpty,varNull
else
result := false;
end;
end;
function VariantToBoolean(const V: Variant; var Value: boolean): boolean;
var
vd: PVarData;
tmp: TVarData;
begin
vd := VarDataFromVariant(V);
repeat
case cardinal(vd^.VType) of
varEmpty,
varNull:
begin
result := false;
exit;
end;
varBoolean: // 16-bit WordBool to 8-bit boolean
if vd^.VBoolean then
Value := true // normalize
else
Value := false;
varInteger: // coming e.g. from TGetJsonField
Value := vd^.VInteger = 1;
varString:
Value := GetBoolean(vd^.VAny);
varOleStr:
Value := WideString(vd^.VAny) = 'true';
{$ifdef HASVARUSTRING}
varUString:
Value := UnicodeString(vd^.VAny) = 'true';
{$endif HASVARUSTRING}
else
begin
vd := SetVarDataUnRefSimpleValue(vd, tmp{%H-});
if vd <> nil then
continue;
result := false;
exit;
end;
end;
break;
until false;
result := true;
end;
function VariantToInt64(const V: Variant; var Value: Int64): boolean;
var
vd: PVarData;
tmp: TVarData;
begin
vd := VarDataFromVariant(V);
repeat
case cardinal(vd^.VType) of
varNull,
varEmpty:
Value := 0;
varBoolean:
if vd^.VBoolean then
Value := 1
else
Value := 0; // normalize
varSmallint:
Value := vd^.VSmallInt;
varShortInt:
Value := vd^.VShortInt;
varWord:
Value := vd^.VWord;
varLongWord,
varOleUInt:
Value := vd^.VLongWord;
varByte:
Value := vd^.VByte;
varInteger,
varOleInt:
Value := vd^.VInteger;
varWord64:
if vd^.VInt64 >= 0 then
Value := vd^.VInt64
else
begin
result := false;
exit;
end;
varInt64:
Value := vd^.VInt64;
else
begin
vd := SetVarDataUnRefSimpleValue(vd, tmp{%H-});
if vd <> nil then
continue;
result := false;
exit;
end;
end;
break;
until false;
result := true;
end;
function VariantToInt64Def(const V: Variant; DefaultValue: Int64): Int64;
begin
if not VariantToInt64(V, result) then
result := DefaultValue;
end;
function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer;
begin
if not VariantToInteger(V, result) then
result := DefaultValue;
end;
procedure RawUtf8ToVariant(Txt: PUtf8Char; TxtLen: integer; var Value: variant);
begin
ClearVariantForString(Value);
FastSetString(RawUtf8(TVarData(Value).VString), Txt, TxtLen);
end;
procedure RawUtf8ToVariant(const Txt: RawUtf8; var Value: variant);
begin
ClearVariantForString(Value);
if Txt = '' then
exit;
RawUtf8(TVarData(Value).VAny) := Txt;
EnsureRawUtf8(RawByteString(TVarData(Value).VAny));
end;
function RawUtf8ToVariant(const Txt: RawUtf8): variant;
begin
RawUtf8ToVariant(Txt, result{%H-});
end;
procedure VariantStringToUtf8(const V: Variant; var result: RawUtf8);
begin
with VarDataFromVariant(V)^ do
if cardinal(VType) = varString then
result := RawUtf8(VString)
else
result := '';
end;
function VariantStringToUtf8(const V: Variant): RawUtf8;
begin
VariantStringToUtf8(V, result{%H-});
end;
procedure _VariantClearSeveral(V: PVariant; n: integer);
begin
if n > 0 then
repeat
VarClear(V^);
inc(V);
dec(n);
until n = 0;
end;
function VariantCompSimple(const A, B: variant): integer;
var
a64, b64: Int64;
af64, bf64: double;
begin
// directly handle ordinal and floating point values
if VariantToInt64(A, a64) and
VariantToInt64(B, b64) then
result := CompareInt64(a64, b64)
else if VariantToDouble(A, af64) and
VariantToDouble(B, bf64) then
result := CompareFloat(af64, bf64)
else
// inlined VarCompareValue() for complex/mixed types
if A = B then
result := 0
else if A < B then // both FPC and Delphi RTL require these two comparisons
result := -1
else
result := 1;
end;
function _SortDynArrayVariantComp(const A, B: TVarData;
{%H-}caseInsensitive: boolean): integer;
// caseInsensitive not supported by the RTL -> include mormot.core.variants
begin
result := VariantCompSimple(PVariant(@A)^, PVariant(@B)^);
end;
{ ************ Sorting/Comparison Functions }
function SortMatch(CompareResult: integer; CompareOperator: TCompareOperator): boolean;
begin
case CompareOperator of
coEqualTo:
result := CompareResult = 0;
coNotEqualTo:
result := CompareResult <> 0;
coLessThan:
result := CompareResult < 0;
coLessThanOrEqualTo:
result := CompareResult <= 0;
coGreaterThan:
result := CompareResult > 0;
// coGreaterThanOrEqualTo:
else
result := CompareResult >= 0;
end;
end;
function SortDynArrayVariant(const A, B): integer;
begin
result := SortDynArrayVariantComp(TVarData(A), TVarData(B), {caseins=}false);
end;
function SortDynArrayVariantI(const A, B): integer;
begin
result := SortDynArrayVariantComp(TVarData(A), TVarData(B), {caseins=}true);
end;
function SortDynArrayBoolean(const A, B): integer;
begin
if boolean(A) then // normalize (seldom used, anyway)
if boolean(B) then
result := 0
else
result := 1
else if boolean(B) then
result := -1
else
result := 0;
end;
function SortDynArrayByte(const A, B): integer;
begin
result := byte(A) - byte(B);
end;
function SortDynArraySmallint(const A, B): integer;
begin
result := smallint(A) - smallint(B);
end;
function SortDynArrayShortint(const A, B): integer;
begin
result := shortint(A) - shortint(B);
end;
function SortDynArrayWord(const A, B): integer;
begin
result := word(A) - word(B);
end;
function SortDynArrayExtended(const A, B): integer;
begin
result := ord(TSynExtended(A) > TSynExtended(B)) - ord(TSynExtended(A) < TSynExtended(B));
end;
function SortDynArrayString(const A, B): integer;
begin
{$ifdef UNICODE}
result := StrCompW(PWideChar(A), PWideChar(B));
{$else}
{$ifdef CPUINTEL}
result := SortDynArrayAnsiString(A, B); // has its own optimized asm
{$else}
result := StrComp(PUtf8Char(A), PUtf8Char(B));
{$endif CPUINTEL}
{$endif UNICODE}
end;
function SortDynArrayUnicodeString(const A, B): integer;
begin
// works for both tkWString and tkUString
result := StrCompW(PWideChar(A), PWideChar(B));
end;
function CompareHash(A, B: PPointer; Len: integer): integer;
{$ifdef HASINLINE}inline;{$endif}
begin
repeat
result := ComparePointer(A^, B^); // on FPC inlined is better than explicit
if result <> 0 then
exit; // trailing register-size memory is seldom equal during sort
inc(A);
inc(B);
dec(Len);
until Len = 0;
end;
function SortDynArray128(const A, B): integer;
begin
{$ifdef CPU64}
result := ord(THash128Rec(A).L > THash128Rec(B).L) -
ord(THash128Rec(A).L < THash128Rec(B).L);
if result = 0 then
result := ord(THash128Rec(A).H > THash128Rec(B).H) -
ord(THash128Rec(A).H < THash128Rec(B).H);
{$else}
result := CompareHash(@A, @B, SizeOf(THash128) div SizeOf(pointer));
{$endif CPU64}
end;
function SortDynArray256(const A, B): integer;
begin
result := CompareHash(@A, @B, SizeOf(THash256) div SizeOf(pointer));
end;
function SortDynArray512(const A, B): integer;
begin
result := CompareHash(@A, @B, SizeOf(THash512) div SizeOf(pointer));
end;
function SortDynArrayPUtf8Char(const A, B): integer;
begin
result := StrComp(pointer(A), pointer(B));
end;
function SortDynArrayShortString(const A, B): integer;
var
sa: shortstring absolute A;
sb: shortstring absolute B;
la, lb: PtrInt;
begin
la := ord(sa[0]);
lb := ord(sb[0]);
if la < lb then
la := lb;
result := MemCmp(@sa[1], @sb[1], la);
if result = 0 then
result := ord(sa[0]) - ord(sb[0]);
end;
{$if not defined(CPUX64ASM) and not defined(CPUX86)} // fallback if no asm
procedure DynArrayHashTableAdjust(P: PIntegerArray; deleted: integer; count: PtrInt);
begin
repeat
dec(count, 8);
dec(P[0], ord(P[0] > deleted)); // branchless code is 10x faster than if :)
dec(P[1], ord(P[1] > deleted));
dec(P[2], ord(P[2] > deleted));
dec(P[3], ord(P[3] > deleted));
dec(P[4], ord(P[4] > deleted));
dec(P[5], ord(P[5] > deleted));
dec(P[6], ord(P[6] > deleted));
dec(P[7], ord(P[7] > deleted));
P := @P[8];
until count < 8;
while count > 0 do
begin
dec(count);
dec(P[count], ord(P[count] > deleted));
end;
end;
procedure DynArrayHashTableAdjust16(P: PWordArray; deleted: cardinal; count: PtrInt);
begin
repeat // branchless code is 10x faster than if :)
dec(count, 8);
dec(P[0], cardinal(P[0] > deleted));
dec(P[1], cardinal(P[1] > deleted));
dec(P[2], cardinal(P[2] > deleted));
dec(P[3], cardinal(P[3] > deleted));
dec(P[4], cardinal(P[4] > deleted));
dec(P[5], cardinal(P[5] > deleted));
dec(P[6], cardinal(P[6] > deleted));
dec(P[7], cardinal(P[7] > deleted));
P := @P[8];
until count < 8;
while count > 0 do
begin
dec(count);
dec(P[count], cardinal(P[count] > deleted));
end;
end;
{$ifend}
procedure ExchgPointer(n1, n2: PPointer);
var
n: pointer;
begin
n := n2^;
n2^ := n1^;
n1^ := n;
end;
procedure ExchgPointers(n1, n2: PPointer; count: PtrInt);
var
n: pointer;
begin
repeat
n := n2^;
n2^ := n1^;
n1^ := n;
inc(n1);
inc(n2);
dec(count);
until count = 0;
end;
procedure ExchgVariant(v1, v2: PPtrIntArray);
var
c: PtrInt; // 32-bit: 16 bytes = 4 PtrInt; 64-bit: 24 bytes = 3 PtrInt
begin
c := v2[0];
v2[0] := v1[0];
v1[0] := c;
c := v2[1];
v2[1] := v1[1];
v1[1] := c;
c := v2[2];
v2[2] := v1[2];
v1[2] := c;
{$ifdef CPU32}
c := v2[3];
v2[3] := v1[3];
v1[3] := c;
{$endif CPU32}
end;
procedure Exchg(P1, P2: PAnsiChar; count: PtrInt);
var
i, c: PtrInt;
u: AnsiChar;
begin
i := count shr POINTERSHR;
if i <> 0 then
repeat
c := PPtrInt(P1)^;
PPtrInt(P1)^ := PPtrInt(P2)^;
PPtrInt(P2)^ := c;
inc(P1, SizeOf(c));
inc(P2, SizeOf(c));
dec(i);
until i = 0;
i := count and POINTERAND;
if i <> 0 then
repeat
dec(i);
u := P1[i];
P1[i] := P2[i];
P2[i] := u;
until i = 0;
end;
{ ************ Some Convenient TStream descendants }
{ TStreamWithPosition }
{$ifdef FPC}
function TStreamWithPosition.GetPosition: Int64;
begin
result := fPosition;
end;
{$endif FPC}
function TStreamWithPosition.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
var
size: Int64;
begin
if (Offset <> 0) or
(Origin <> soCurrent) then
begin
size := GetSize;
case Origin of
soBeginning:
result := Offset;
soEnd:
result := size - Offset;
else
result := fPosition + Offset; // soCurrent
end;
if result > size then
result := size
else if result < 0 then
result := 0;
fPosition := result;
end
else
// optimize on Delphi when retrieving TStream.Position as Seek(0,soCurrent)
result := fPosition;
end;
function TStreamWithPosition.Seek(Offset: Longint; Origin: Word): Longint;
begin
result := Seek(Offset, TSeekOrigin(Origin)); // call the 64-bit version above
end;
{ TStreamWithPositionAndSize }
function TStreamWithPositionAndSize.GetSize: Int64;
begin
result := fSize;
end;
{ TRawByteStringStream }
constructor TRawByteStringStream.Create(const aString: RawByteString);
begin
fDataString := aString;
end;
function TRawByteStringStream.Read(var Buffer; Count: Longint): Longint;
begin
if Count <= 0 then
result := 0
else
begin
result := Length(fDataString) - fPosition;
if result = 0 then
exit;
if result > Count then
result := Count;
MoveFast(PByteArray(fDataString)[fPosition], Buffer, result);
inc(fPosition, result);
end;
end;
function TRawByteStringStream.GetSize: Int64;
begin
// faster than the TStream inherited method calling Seek() twice
result := length(fDataString);
end;
procedure TRawByteStringStream.SetSize(NewSize: Longint);
begin
SetLength(fDataString, NewSize);
if fPosition > NewSize then
fPosition := NewSize;
end;
function TRawByteStringStream.Write(const Buffer; Count: Longint): Longint;
begin
result := Count;
if result > 0 then
if fDataString = '' then // inlined FastSetString()
begin
pointer(fDataString) := FastNewString(result, CP_UTF8);
MoveFast(Buffer, pointer(fDataString)^, result);
fPosition := result;
end
else
begin
if fPosition + result > length(fDataString) then
SetLength(fDataString, fPosition + result); // resize
MoveFast(Buffer, PByteArray(fDataString)[fPosition], result);
inc(fPosition, result);
end;
end;
procedure TRawByteStringStream.GetAsText(StartPos, Len: PtrInt; var Text: RawUtf8);
var
L: PtrInt;
begin
if StartPos < 0 then
StartPos := 0;
L := length(fDataString);
if (L = 0) or
(StartPos >= L) then
FastAssignNew(Text) // nothing to return
else if (StartPos = 0) and
(Len = L) and
(PStrCnt(PAnsiChar(pointer(fDataString)) - _STRCNT)^ = 1) then
FastAssignUtf8(Text, fDataString) // fast return the fDataString instance
else
begin
dec(L, StartPos);
if Len > L then
Len := L; // avoid any buffer overflow
FastSetString(Text, @PByteArray(fDataString)[StartPos], Len);
end;
end;
procedure TRawByteStringStream.Clear;
begin
fPosition := 0;
fDataString := '';
end;
{ TSynMemoryStream }
constructor TSynMemoryStream.Create(const aText: RawByteString);
begin
inherited Create;
SetPointer(pointer(aText), length(aText));
end;
constructor TSynMemoryStream.Create(Data: pointer; DataLen: PtrInt);
begin
inherited Create;
SetPointer(Data, DataLen);
end;
function TSynMemoryStream.Write(const Buffer; Count: integer): Longint;
begin
result := RaiseStreamError(self, 'Write');
end;
function {%H-}RaiseStreamError(Caller: TObject; const Context: shortstring): PtrInt;
begin
raise EStreamError.CreateFmt('Unexpected %s.%s', [ClassNameShort(Caller)^, Context]);
end;
procedure crc32tabInit(polynom: cardinal; var tab: TCrc32tab);
var
i, n: PtrUInt;
crc: cardinal;
begin // 256 bytes of code to generate 2 x 8KB lookup tables
i := 0;
repeat // unrolled branchless root lookup table generation
crc := cardinal(-(i and 1) and polynom) xor (i shr 1);
crc := cardinal(-(crc and 1) and polynom) xor (crc shr 1);
crc := cardinal(-(crc and 1) and polynom) xor (crc shr 1);
crc := cardinal(-(crc and 1) and polynom) xor (crc shr 1);
crc := cardinal(-(crc and 1) and polynom) xor (crc shr 1);
crc := cardinal(-(crc and 1) and polynom) xor (crc shr 1);
crc := cardinal(-(crc and 1) and polynom) xor (crc shr 1);
crc := cardinal(-(crc and 1) and polynom) xor (crc shr 1);
tab[0, i] := crc;
if i = 255 then
break;
inc(i);
until false;
i := 0;
repeat // expand the root lookup table for by-8 fast computation
crc := tab[0, i];
for n := 1 to high(tab) do
begin
crc := (crc shr 8) xor tab[0, ToByte(crc)];
tab[n, i] := crc;
end;
inc(i);
until i > 256;
end;
procedure InitializeUnit;
begin
assert(ord(high(TSynLogLevel)) = 31);
// initialize internal constants
crc32tabInit(2197175160, crc32ctab); // crc32c() reversed polynom
crc32tabInit(3988292384, crc32tab); // crc32() = zlib's reversed polynom
// setup minimalistic global functions - overriden by other core units
VariantClearSeveral := @_VariantClearSeveral;
SortDynArrayVariantComp := @_SortDynArrayVariantComp;
// initialize CPU-specific asm
TestCpuFeatures;
end;
initialization
InitializeUnit;
end.
Reference in New Issue Copy Permalink