{
pascalx.lang — основной модуль для разработки программ и библиотек
(только для архитектуры x86-64).
Copyright © 2021, 2026 Малик Разработчик
Это свободная программа: вы можете перераспространять её и/или изменять
её на условиях Меньшей Стандартной общественной лицензии GNU в том виде,
в каком она была опубликована Фондом свободного программного обеспечения;
либо версии 3 лицензии, либо (по вашему выбору) любой более поздней версии.
Эта программа распространяется в надежде, что она будет полезной,
но БЕЗО ВСЯКИХ ГАРАНТИЙ; даже без неявной гарантии ТОВАРНОГО ВИДА
или ПРИГОДНОСТИ ДЛЯ ОПРЕДЕЛЁННЫХ ЦЕЛЕЙ. Подробнее см. в Меньшей Стандартной
общественной лицензии GNU.
Вы должны были получить копию Меньшей Стандартной общественной лицензии GNU
вместе с этой программой. Если это не так, см.
<https://www.gnu.org/licenses/>.
}
unit pascalx.lang;
{$MODE OBJFPC}
{$MODESWITCH TYPEHELPERS}
interface
{$IFNDEF CPUX86_64}
{$ERROR this unit is for x86-64 architecture only.}
{$ENDIF}
{$IFNDEF FPC_HAS_FEATURE_RTTI}
{$ERROR this unit requires RTTI support.}
{$ENDIF}
{$IFNDEF FPC_HAS_FEATURE_DYNARRAYS}
{$ERROR this unit requires dynamic array type support.}
{$ENDIF}
{$IFNDEF FPC_HAS_FEATURE_CLASSES}
{$ERROR this unit requires class type support.}
{$ENDIF}
{$IFNDEF FPC_HAS_FEATURE_ANSISTRINGS}
{$ERROR this unit requires AnsiString support.}
{$ENDIF}
{$IFNDEF FPC_HAS_FEATURE_UNICODESTRINGS}
{$ERROR this unit requires UnicodeString support.}
{$ENDIF}
{$IFNDEF FPC_HAS_FEATURE_EXCEPTIONS}
{$ERROR this unit requires exceptions support.}
{$ENDIF}
{$IFNDEF FPC_HAS_FEATURE_RESOURCES}
{$ERROR this unit requires resources support.}
{$ENDIF}
{%region} uses
{$IFDEF WINDOWS}
windows
{$ELSE}
unixtype,
baseunix,
pthreads,
cthreads
{$ENDIF},
typinfo;
{%endregion}
{$WARN 3018 OFF} { позволить конструкторы с любой видимостью }
{$TYPEINFO ON}
{$CALLING REGISTER}
const UNIT_NAME = 'pascalx.lang';
{%region} type
boolean = system.Boolean;
char = system.AnsiChar;
uchar = system.UnicodeChar;
byte = system.Int8;
short = system.Int16;
int = system.Int32;
long = system.Int64;
float = system.Single;
double = system.Double;
real = {$IFDEF WINDOWS}packed array [0..9] of system.UInt8{$ELSE}system.Extended{$ENDIF};
{$TYPEINFO OFF}
{$INTERFACES CORBA}
ISimple = interface;
RawInterface = interface;
{$INTERFACES COM}
RefCountInterface = interface;
{$INTERFACES DEFAULT}
{$TYPEINFO ON}
&Property = interface;
&Class = interface;
Runnable = interface;
Value = interface;
Serializable = interface;
&Object = class;
RefCountObject = class;
DynamicObject = class;
CoBoolean = class;
CoChar = class;
CoUChar = class;
CoByte = class;
CoShort = class;
CoInt = class;
CoLong = class;
CoFloat = class;
CoDouble = class;
CoReal = class;
CoAnsiString = class;
CoUnicodeString = class;
CoObject = class;
CoSimple = class;
CoUnknown = class;
RealRepresenter = class;
Mutex = class;
Monitor = class;
Thread = class;
Throwable = class;
Exception = class;
PropertyException = class;
PropertyNotFoundException = class;
IllegalPropertyTypeException = class;
IllegalPropertyAccessException = class;
RuntimeException = class;
ArithmeticException = class;
ClassCastException = class;
IllegalStateException = class;
IllegalMonitorStateException = class;
IllegalThreadStateException = class;
IllegalArgumentException = class;
IllegalPropertyValueException = class;
NumberFormatException = class;
IndexOutOfBoundsException = class;
ArrayIndexOutOfBoundsException = class;
StringIndexOutOfBoundsException = class;
NegativeArraySizeException = class;
NullPointerException = class;
SecurityException = class;
SafecallException = class;
UnsupportedOperationException = class;
ReadOnlyPropertyException = class;
WriteOnlyPropertyException = class;
Error = class;
ClassContentError = class;
AbstractMethodError = class;
BufferTooLargeError = class;
MachineError = class;
StackOverflowError = class;
MemoryError = class;
OutOfMemoryError = class;
InvalidPointerError = class;
AResource = class;
Lang = class;
Math = class;
&Array = class;
generic DynamicArray<ComponentType> = packed array of ComponentType;
{ boolean[] } boolean_Array1d = specialize DynamicArray<boolean>;
{ char[] } char_Array1d = specialize DynamicArray<char>;
{ uchar[] } uchar_Array1d = specialize DynamicArray<uchar>;
{ byte[] } byte_Array1d = specialize DynamicArray<byte>;
{ short[] } short_Array1d = specialize DynamicArray<short>;
{ int[] } int_Array1d = specialize DynamicArray<int>;
{ long[] } long_Array1d = specialize DynamicArray<long>;
{ float[] } float_Array1d = specialize DynamicArray<float>;
{ double[] } double_Array1d = specialize DynamicArray<double>;
{ real[] } real_Array1d = specialize DynamicArray<real>;
{ AnsiString[] } AnsiString_Array1d = specialize DynamicArray<AnsiString>;
{ UnicodeString[] } UnicodeString_Array1d = specialize DynamicArray<UnicodeString>;
{ Pointer[] } Pointer_Array1d = specialize DynamicArray<Pointer>;
{ TObject[] } TObject_Array1d = specialize DynamicArray<TObject>;
{ Thread[] } Thread_Array1d = specialize DynamicArray<Thread>;
{ ISimple[] } ISimple_Array1d = specialize DynamicArray<ISimple>;
{ IUnknown[] } IUnknown_Array1d = specialize DynamicArray<IUnknown>;
{ &Property[] } Property_Array1d = specialize DynamicArray<&Property>;
{ &Class[] } Class_Array1d = specialize DynamicArray<&Class>;
{ boolean[][] } boolean_Array2d = specialize DynamicArray<boolean_Array1d>;
{ char[][] } char_Array2d = specialize DynamicArray<char_Array1d>;
{ uchar[][] } uchar_Array2d = specialize DynamicArray<uchar_Array1d>;
{ byte[][] } byte_Array2d = specialize DynamicArray<byte_Array1d>;
{ short[][] } short_Array2d = specialize DynamicArray<short_Array1d>;
{ int[][] } int_Array2d = specialize DynamicArray<int_Array1d>;
{ long[][] } long_Array2d = specialize DynamicArray<long_Array1d>;
{ float[][] } float_Array2d = specialize DynamicArray<float_Array1d>;
{ double[][] } double_Array2d = specialize DynamicArray<double_Array1d>;
{ real[][] } real_Array2d = specialize DynamicArray<real_Array1d>;
{ AnsiString[][] } AnsiString_Array2d = specialize DynamicArray<AnsiString_Array1d>;
{ UnicodeString[][] } UnicodeString_Array2d = specialize DynamicArray<UnicodeString_Array1d>;
{ Pointer[][] } Pointer_Array2d = specialize DynamicArray<Pointer_Array1d>;
{ TObject[][] } TObject_Array2d = specialize DynamicArray<TObject_Array1d>;
{ Thread[][] } Thread_Array2d = specialize DynamicArray<Thread_Array1d>;
{ ISimple[][] } ISimple_Array2d = specialize DynamicArray<ISimple_Array1d>;
{ IUnknown[][] } IUnknown_Array2d = specialize DynamicArray<IUnknown_Array1d>;
{ &Property[][] } Property_Array2d = specialize DynamicArray<Property_Array1d>;
{ &Class[][] } Class_Array2d = specialize DynamicArray<Class_Array1d>;
{$TYPEINFO OFF}
{$INTERFACES CORBA}
ISimple = interface ['{00000000-0000-0000-C000-000000000047}']
function queryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid: system.TGuid; out obj): int; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
end;
RawInterface = interface(ISimple) ['{F5377D1E-7AF2-4BBA-822E-778B4F7D652E}']
procedure dispatch(var message);
procedure dispatchStr(var message);
procedure defaultHandler(var message);
procedure defaultHandlerStr(var message);
function getInterface(const iid: system.TGuid; out obj): boolean;
function getInterface(const iid: ShortString; out obj): boolean;
function getInterfaceWeak(const iid: system.TGuid; out obj): boolean;
function getInterfaceByStr(const iid: ShortString; out obj): boolean;
function equals(anot: TObject): boolean;
function getHashCode(): long;
function toString(): AnsiString;
function fieldAddress(const name: ShortString): Pointer;
function safeCallException(exceptObject: TObject; exceptAddress: Pointer): system.HResult;
end;
{$INTERFACES COM}
RefCountInterface = interface(IUnknown) ['{F5377D1E-7AF2-4BBA-822E-778B4F7D652F}']
procedure dispatch(var message);
procedure dispatchStr(var message);
procedure defaultHandler(var message);
procedure defaultHandlerStr(var message);
function getInterface(const iid: system.TGuid; out obj): boolean;
function getInterface(const iid: ShortString; out obj): boolean;
function getInterfaceWeak(const iid: system.TGuid; out obj): boolean;
function getInterfaceByStr(const iid: ShortString; out obj): boolean;
function equals(anot: TObject): boolean;
function getHashCode(): long;
function toString(): AnsiString;
function fieldAddress(const name: ShortString): Pointer;
function safeCallException(exceptObject: TObject; exceptAddress: Pointer): system.HResult;
end;
{$INTERFACES DEFAULT}
{$TYPEINFO ON}
&Property = interface(RefCountInterface) ['{F5377D1E-7AF2-4BBA-822E-778B4F7D6530}']
function isReadable(): boolean;
function isWriteable(): boolean;
function isStoreable(): boolean;
function getName(): AnsiString;
function getType(): &Class;
end;
&Class = interface(RefCountInterface) ['{F5377D1E-7AF2-4BBA-822E-778B4F7D6531}']
function isPointer(): boolean;
function isPrimitive(): boolean;
function isInstance(ref: TObject): boolean;
function isInstance(ref: ISimple): boolean;
function isInstance(ref: IUnknown): boolean;
function isAssignableFrom(cls: &Class): boolean;
function getTypeKind(): int;
function getUnitName(): AnsiString;
function getSimpleName(): AnsiString;
function getOriginalUnit(): AnsiString;
function getOriginalName(): AnsiString;
function getCanonicalName(): AnsiString;
function getProperties(): Property_Array1d;
function getInterfaces(): Class_Array1d;
function getProperty(const name: AnsiString): &Property;
function getSuperclass(): &Class;
function getReference(): &Class;
function getComponentType(): &Class;
function createInstance(): DynamicObject;
end;
Runnable = interface(RawInterface) ['{5BF760E3-0DD8-49EE-AEB9-F3A7978E21CD}']
procedure run();
end;
Value = interface(RefCountInterface) ['{A3919068-04E5-47B0-A10D-591E2A664127}']
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
Serializable = interface(Value) ['{A3919068-04E5-47B0-A10D-591E2A664128}']
procedure writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
function getSize(): int;
end;
{$TYPEINFO OFF}
generic Collection<ComponentType> = interface(RefCountInterface)
procedure copyInto(const dstArray; dstOffset: int = 0);
function getLength(): int;
function componentAt(index: int): ComponentType;
function toArray(): specialize DynamicArray<ComponentType>;
property length: int read getLength;
property component[index: int]: ComponentType read componentAt; default;
end;
{$TYPEINFO ON}
Thread_Collection1d = specialize Collection<Thread>;
&Object = class(TObject, ISimple, RawInterface, IUnknown, RefCountInterface)
public
constructor create();
destructor destroy; override;
procedure afterConstruction(); override;
procedure beforeDestruction(); override;
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
{$IFDEF WINDOWS}{$CALLING STDCALL}{$ELSE}{$CALLING CDECL}{$ENDIF}
function queryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid: system.TGuid; out obj): int; virtual;
function _addref(): int; virtual;
function _release(): int; virtual;
{$CALLING REGISTER}
end;
RefCountObject = class(&Object)
public
class function newInstance(): TObject; override; final;
private
fldRefCount: int;
public
procedure afterConstruction(); override;
procedure beforeDestruction(); override;
{$IFDEF WINDOWS}{$CALLING STDCALL}{$ELSE}{$CALLING CDECL}{$ENDIF}
function _addref(): int; override; final;
function _release(): int; override; final;
{$CALLING REGISTER}
end;
DynamicObject = class(RefCountObject)
public
constructor create(); virtual;
end;
CoBoolean = class sealed(RefCountObject, Serializable, Value)
private
fldValue: byte;
public
constructor create(const value: boolean);
procedure writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getSize(): int;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
CoChar = class sealed(RefCountObject, Serializable, Value)
public const
MIN_RADIX = int(2);
MAX_RADIX = int(36);
MIN_VALUE = char(#$00);
MAX_VALUE = char(#$ff);
public
class function isDigit(character: char): boolean; static;
class function isLowerCase(character: char): boolean; static;
class function isUpperCase(character: char): boolean; static;
class function toLowerCase(character: char): char; static;
class function toUpperCase(character: char): char; static;
class function toChar(digit: int): char; static;
class function toDigit(character: char; radix: int): int; static;
private
fldValue: char;
public
constructor create(const value: char);
procedure writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getSize(): int;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
CoUChar = class sealed(RefCountObject, Serializable, Value)
public const
MIN_RADIX = int(2);
MAX_RADIX = int(36);
MIN_VALUE = uchar(#$0000);
MAX_VALUE = uchar(#$ffff);
public
class function isDigit(character: uchar): boolean; static;
class function isLowerCase(character: uchar): boolean; static;
class function isUpperCase(character: uchar): boolean; static;
class function toLowerCase(character: uchar): uchar; static;
class function toUpperCase(character: uchar): uchar; static;
class function toChar(digit: int): uchar; static;
class function toDigit(character: uchar; radix: int): int; static;
private
fldValue: uchar;
public
constructor create(const value: uchar);
procedure writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getSize(): int;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
CoByte = class sealed(RefCountObject, Serializable, Value)
public const
MIN_VALUE = byte(-$80);
MAX_VALUE = byte($7f);
public
class function parse(const str: AnsiString; radix: int = 10): byte; static;
class function parseUnsigned(const str: AnsiString; radix: int = 10): byte; static;
private
fldValue: byte;
public
constructor create(const value: byte);
procedure writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getSize(): int;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
CoShort = class sealed(RefCountObject, Serializable, Value)
public const
MIN_VALUE = short(-$8000);
MAX_VALUE = short($7fff);
public
class function parse(const str: AnsiString; radix: int = 10): short; static;
class function parseUnsigned(const str: AnsiString; radix: int = 10): short; static;
class function byteSwap(value: short): short; static;
private
fldValue: short;
public
constructor create(const value: short);
procedure writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getSize(): int;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
CoInt = class sealed(RefCountObject, Serializable, Value)
private
class function toUnsignedStringByShift(uvalue: int; shift: int): AnsiString; static;
public const
MIN_VALUE = int(-$80000000);
MAX_VALUE = int($7fffffff);
public
class function parse(const str: AnsiString; radix: int = 10): int; static;
class function parseUnsigned(const str: AnsiString; radix: int = 10): int; static;
class function byteSwap(value: int): int; static;
class function bound(value, minimum, maximum: int): int; static;
class function max(value1, value2: int): int; static;
class function min(value1, value2: int): int; static;
class function sar(value: int; bits: int): int; static;
class function rol(value: int; bits: int): int; static;
class function boundUnsigned(uvalue, uminimum, umaximum: int): int; static;
class function cmpUnsigned(uvalue1, uvalue2: int): int; static;
class function divUnsigned(uvalue1, uvalue2: int): int; static;
class function remUnsigned(uvalue1, uvalue2: int): int; static;
class function maxUnsigned(uvalue1, uvalue2: int): int; static;
class function minUnsigned(uvalue1, uvalue2: int): int; static;
class function toFloatBits(value: int): float; static;
class function toFloat(value: int): float; static;
class function toUnsignedFloat(uvalue: int): float; static;
class function toDouble(value: int): double; static;
class function toUnsignedDouble(uvalue: int): double; static;
class function toReal(value: int): real; static;
class function toUnsignedReal(uvalue: int): real; static;
class function toString(value: int; radix: int = 10): AnsiString; static;
class function toUnsignedString(uvalue: int; radix: int = 10): AnsiString; static;
class function toLeadZeroString(value: int; width: int; radix: int = 10): AnsiString; static;
class function toBinaryString(uvalue: int): AnsiString; static;
class function toOctalString(uvalue: int): AnsiString; static;
class function toHexString(uvalue: int): AnsiString; static;
private
fldValue: int;
public
constructor create(const value: int);
procedure writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getSize(): int;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
CoLong = class sealed(RefCountObject, Serializable, Value)
private
class function toUnsignedStringByShift(uvalue: long; shift: int): AnsiString; static;
public const
MIN_VALUE = long(-$8000000000000000);
MAX_VALUE = long($7fffffffffffffff);
public
class function parse(const str: AnsiString; radix: int = 10): long; static;
class function parseUnsigned(const str: AnsiString; radix: int = 10): long; static;
class function byteSwap(value: long): long; static;
class function bound(value, minimum, maximum: long): long; static;
class function max(value1, value2: long): long; static;
class function min(value1, value2: long): long; static;
class function sar(value: long; bits: int): long; static;
class function rol(value: long; bits: int): long; static;
class function boundUnsigned(uvalue, uminimum, umaximum: long): long; static;
class function cmpUnsigned(uvalue1, uvalue2: long): int; static;
class function divUnsigned(uvalue1, uvalue2: long): long; static;
class function remUnsigned(uvalue1, uvalue2: long): long; static;
class function maxUnsigned(uvalue1, uvalue2: long): long; static;
class function minUnsigned(uvalue1, uvalue2: long): long; static;
class function toDoubleBits(value: long): double; static;
class function toFloat(value: long): float; static;
class function toUnsignedFloat(uvalue: long): float; static;
class function toDouble(value: long): double; static;
class function toUnsignedDouble(uvalue: long): double; static;
class function toReal(value: long): real; static;
class function toUnsignedReal(uvalue: long): real; static;
class function toString(value: long; radix: int = 10): AnsiString; static;
class function toUnsignedString(uvalue: long; radix: int = 10): AnsiString; static;
class function toLeadZeroString(value: long; width: int; radix: int = 10): AnsiString; static;
class function toBinaryString(uvalue: long): AnsiString; static;
class function toOctalString(uvalue: long): AnsiString; static;
class function toHexString(uvalue: long): AnsiString; static;
private
fldValue: long;
public
constructor create(const value: long);
procedure writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getSize(): int;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
CoFloat = class sealed(RefCountObject, Serializable, Value)
public const
MIN_VALUE = float(1.40129846432481707e-45);
MAX_VALUE = float(3.40282346638528860e+38);
POSITIVE_INFINITY = float(+1.0 / 0.0);
NEGATIVE_INFINITY = float(-1.0 / 0.0);
NEGATIVE_ZERO = float(0.0 / -1.0);
NAN = float(0.0 / 0.0);
public
class function parse(const str: AnsiString): float; static;
class function isNaN(value: float): boolean; static;
class function isInfinite(value: float): boolean; static;
class function cmpl(value1, value2: float): int; static;
class function cmpg(value1, value2: float): int; static;
class function rem(value1, value2: float): float; static;
class function max(value1, value2: float): float; static;
class function min(value1, value2: float): float; static;
class function bound(value, minimum, maximum: float): float; static;
class function toIntBits(value: float): int; static;
class function toInt(value: float): int; static;
class function toUnsignedInt(value: float): int; static;
class function toLong(value: float): long; static;
class function toUnsignedLong(value: float): long; static;
class function toDouble(value: float): double; static;
class function toReal(value: float): real; static;
class function toString(value: float): AnsiString; static;
class function toString(value: float; sigDigits, ordDigits: int;
sigAll: boolean = false; ordAll: boolean = true; expForm: boolean = false;
sigSign: boolean = false; ordSign: boolean = true): AnsiString; static;
private
fldValue: float;
public
constructor create(const value: float);
procedure writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getSize(): int;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
CoDouble = class sealed(RefCountObject, Serializable, Value)
public const
MIN_VALUE = double(4.94065645841246544e-324);
MAX_VALUE = double(1.79769313486231571e+308);
POSITIVE_INFINITY = double(+1.0 / 0.0);
NEGATIVE_INFINITY = double(-1.0 / 0.0);
NEGATIVE_ZERO = double(0.0 / -1.0);
NAN = double(0.0 / 0.0);
public
class function parse(const str: AnsiString): double; static;
class function isNaN(value: double): boolean; static;
class function isInfinite(value: double): boolean; static;
class function cmpl(value1, value2: double): int; static;
class function cmpg(value1, value2: double): int; static;
class function rem(value1, value2: double): double; static;
class function max(value1, value2: double): double; static;
class function min(value1, value2: double): double; static;
class function bound(value, minimum, maximum: double): double; static;
class function toLongBits(value: double): long; static;
class function toInt(value: double): int; static;
class function toUnsignedInt(value: double): int; static;
class function toLong(value: double): long; static;
class function toUnsignedLong(value: double): long; static;
class function toFloat(value: double): float; static;
class function toReal(value: double): real; static;
class function toString(value: double): AnsiString; static;
class function toString(value: double; sigDigits, ordDigits: int;
sigAll: boolean = false; ordAll: boolean = true; expForm: boolean = false;
sigSign: boolean = false; ordSign: boolean = true): AnsiString; static;
private
fldValue: double;
public
constructor create(const value: double);
procedure writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getSize(): int;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
CoReal = class sealed(RefCountObject, Serializable, Value)
{$IFDEF WINDOWS}
public
class function MIN_VALUE: real; static;
class function MAX_VALUE: real; static;
class function POSITIVE_INFINITY: real; static;
class function NEGATIVE_INFINITY: real; static;
class function NEGATIVE_ZERO: real; static;
class function NAN: real; static;
{$ELSE}
public const
MIN_VALUE = real(3.6451995318824746e-4951);
MAX_VALUE = real(1.189731495357231765e+4932);
POSITIVE_INFINITY = real(+1.0 / 0.0);
NEGATIVE_INFINITY = real(-1.0 / 0.0);
NEGATIVE_ZERO = real(0.0 / -1.0);
NAN = real(0.0 / 0.0);
{$ENDIF}
public
class function parse(const str: AnsiString): real; static;
class function isNaN(value: real): boolean; static;
class function isInfinite(value: real): boolean; static;
class function cmpl(value1, value2: real): int; static;
class function cmpg(value1, value2: real): int; static;
class function rem(value1, value2: real): real; static;
class function max(value1, value2: real): real; static;
class function min(value1, value2: real): real; static;
class function bound(value, minimum, maximum: real): real; static;
class function extractExponent(const value: real): int; static;
class function extractSignificand(const value: real): long; static;
class function build(exponent: int; significand: long): real; static;
class function toInt(value: real): int; static;
class function toUnsignedInt(value: real): int; static;
class function toLong(value: real): long; static;
class function toUnsignedLong(value: real): long; static;
class function toFloat(value: real): float; static;
class function toDouble(value: real): double; static;
class function toString(value: real): AnsiString; static;
class function toString(value: real; sigDigits, ordDigits: int;
sigAll: boolean = false; ordAll: boolean = true; expForm: boolean = false;
sigSign: boolean = false; ordSign: boolean = true): AnsiString; static;
private
fldValue: real;
public
constructor create(const value: real);
procedure writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getSize(): int;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
CoAnsiString = class sealed(RefCountObject, Value)
public const
LINE_ENDING = AnsiString({$IF DEFINED(WINDOWS)}#$0d#$0a{$ELSEIF DEFINED(UNIX)}#$0a{$ELSE}#$0d{$ENDIF});
private
fldHashComputed: boolean;
fldHashValue: long;
fldValue: AnsiString;
public
constructor create(const value: AnsiString);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
CoUnicodeString = class sealed(RefCountObject, Value)
public const
LINE_ENDING = UnicodeString({$IF DEFINED(WINDOWS)}#$000d#$000a{$ELSEIF DEFINED(UNIX)}#$000a{$ELSE}#$000d{$ENDIF});
private
fldHashComputed: boolean;
fldHashValue: long;
fldValue: UnicodeString;
public
constructor create(const value: UnicodeString);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
CoObject = class sealed(RefCountObject, Value)
private
fldValue: TObject;
public
constructor create(const value: TObject);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
CoSimple = class sealed(RefCountObject, Value)
private
fldValue: ISimple;
public
constructor create(const value: ISimple);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
CoUnknown = class sealed(RefCountObject, Value)
private
fldValue: IUnknown;
public
constructor create(const value: IUnknown);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getType(): int;
function isNaN(): boolean;
function isInfinite(): boolean;
function asBoolean(): boolean;
function asInt(): int;
function asLong(): long;
function asFloat(): float;
function asDouble(): double;
function asReal(): real;
function asAnsiString(): AnsiString;
function asUnicodeString(): UnicodeString;
function asObject(): TObject;
function asSimple(): ISimple;
end;
RealRepresenter = class(&Object)
strict private const
MUL_MIN = long($0ccccccccccccccc);
private
class function tab_04_00(power: int): real; static;
class function tab_08_05(power: int): real; static;
class function tab_12_09(power: int): real; static;
protected
class function round(value: real): long; static;
public const
MIN_ORDER_DIGITS = int(1);
MAX_ORDER_DIGITS = int(4);
REAL_ORDER_DIGITS = int(4);
FLOAT_ORDER_DIGITS = int(2);
DOUBLE_ORDER_DIGITS = int(3);
MIN_SIGNIFICAND_DIGITS = int(2);
MAX_SIGNIFICAND_DIGITS = int(18);
REAL_SIGNIFICAND_DIGITS = int(18);
FLOAT_SIGNIFICAND_DIGITS = int(7);
DOUBLE_SIGNIFICAND_DIGITS = int(15);
public
class function pow10(value: real; power: int): real; static;
private
fldSigAll: boolean;
fldOrdAll: boolean;
fldSigSign: boolean;
fldOrdSign: boolean;
fldExpForm: boolean;
fldSigDigits: int;
fldOrdDigits: int;
fldMinRepresentValue: long;
fldMaxRepresentValue: long;
fldLimitValueWithFractialPart: real;
fldLimitValueWithoutExponent: real;
protected
function parse(const str: AnsiString): real; virtual;
function represent(value: real): char_Array1d; virtual;
property minRepresentValue: long read fldMinRepresentValue;
property maxRepresentValue: long read fldMaxRepresentValue;
property limitValueWithFractialPart: real read fldLimitValueWithFractialPart;
property limitValueWithoutExponent: real read fldLimitValueWithoutExponent;
public
constructor create(sigDigits, ordDigits: int; sigAll: boolean = false; ordAll: boolean = true; expForm: boolean = false; sigSign: boolean = false; ordSign: boolean = true);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function writeTo(const dst: char_Array1d; offset: int; value: real): int; virtual;
function parseFloat(const str: AnsiString): float; virtual;
function parseDouble(const str: AnsiString): double; virtual;
function parseReal(const str: AnsiString): real; virtual;
function toString(value: real): AnsiString; overload; virtual;
function toCharArray(value: real): char_Array1d; virtual;
published
property orderAll: boolean read fldOrdAll;
property orderSign: boolean read fldOrdSign;
property significandAll: boolean read fldSigAll;
property significandSign: boolean read fldSigSign;
property exponentialForm: boolean read fldExpForm;
property orderDigits: int read fldOrdDigits;
property significandDigits: int read fldSigDigits;
end;
Mutex = class(&Object)
private
fldMutex: TRTLCriticalSection;
public
constructor create();
destructor destroy; override;
procedure beginSynchronized(); virtual;
procedure endSynchronized(); virtual;
function isHold(): boolean; virtual;
end;
Monitor = class(Mutex)
strict private const
OWNEDBY = long($794264656e774f07);
BLOCKED = long($64656b636f6c4207);
WAITING = long($676e697469615707);
strict private type
ThreadStateEntry = packed record
case int of
0: (
stateForDebug: String[7];
);
1: (
state: long;
threadId: long;
lockCount: long;
__reserved18: long;
);
end;
{ ThreadStateEntry[] } ThreadStateEntry_Array1d = specialize DynamicArray<ThreadStateEntry>;
private
class function newThreadStateEntryArray1d(length: int): ThreadStateEntry_Array1d; static;
private
fldLength: int;
fldNotifies: long;
fldEntries: ThreadStateEntry_Array1d;
fldOwnedBy: ThreadStateEntry;
procedure resume(const entry: ThreadStateEntry; needSignal: boolean);
procedure extractEntry();
procedure extractEntry(threadId: long);
procedure appendEntry(const entry: ThreadStateEntry);
function getEntryIndexByState(state: long): int;
function getEntryIndexByThreadId(threadId: long): int;
public
procedure beginSynchronized(); override; final;
procedure endSynchronized(); override; final;
procedure notify();
procedure notifyAll();
procedure wait();
procedure wait(timeInMillis: long);
procedure wait(timeInMillis: long; timeInNanos: int);
function isHold(): boolean; override; final;
end;
Thread = class(&Object, Runnable)
private const
FLAG_EXTERNAL = byte($01);
FLAG_AUTO_FREE = byte($02);
public const
UD_PRIORITY = int(0);
MIN_PRIORITY = int(1);
LOW_PRIORITY = int(3);
NORM_PRIORITY = int(5);
HIGH_PRIORITY = int(7);
MAX_PRIORITY = int(9);
public const
MIN_STACK_SIZE = long($000000001000);
DEFAULT_STACK_SIZE = long($000000800000);
MAX_STACK_SIZE = long($000100000000);
public
class procedure yield(); static;
class procedure sleep(timeInMillis: long); static;
class procedure sleep(timeInMillis: long; timeInNanos: int); static;
class function activeCount(): int; static;
{$IFNDEF LIBRARY}
class function enumerate(): Thread_Collection1d; static;
{$ENDIF}
class function current(): Thread; static;
private
fldStarted: boolean;
fldCreated: boolean;
fldTerminated: boolean;
fldFlags: byte;
fldPriority: int;
fldStackSize: long;
fldThreadId1: long;
fldThreadId2: long;
fldEnumerated: long;
fldDescription: AnsiString;
fldTarget: Runnable;
fldJoinMonitor: Monitor;
constructor create(threadId1, threadId2: long; external: boolean = true);
procedure notifyJoined();
procedure freeIfNecessary();
procedure setDescription(const newDescription: AnsiString);
function isStarted(): boolean;
function getFlag(mask: int): boolean;
function getPriority(): int;
function getDescription(): AnsiString;
protected
constructor create(stackSize: long = DEFAULT_STACK_SIZE; freeOnTerminate: boolean = true);
procedure setPriority(newPriority: int); virtual;
public
constructor create(target: Runnable; freeOnTerminate: boolean = true);
constructor create(target: Runnable; stackSize: long; freeOnTerminate: boolean = true);
destructor destroy; override;
procedure run(); virtual;
procedure start(); virtual;
procedure join();
procedure join(timeInMillis: long);
procedure join(timeInMillis: long; timeInNanos: int);
{$IFDEF WINDOWS}{$CALLING STDCALL}{$ELSE}{$CALLING CDECL}{$ENDIF}
function _addref(): int; override; final;
function _release(): int; override; final;
{$CALLING REGISTER}
function isAlive(): boolean;
function isExternal(): boolean;
published
property freeOnTerminate: boolean index FLAG_AUTO_FREE read getFlag;
property priority: int read getPriority write setPriority;
property description: AnsiString read getDescription write setDescription;
end;
Throwable = class(&Object)
private
fldHelpContext: int;
fldMessage: AnsiString;
fldStackTrace: Pointer_Array1d;
public
constructor create(const message: AnsiString = ''; helpContext: int = 0);
procedure printStackTrace();
function toString(): AnsiString; override;
function clone(): Throwable; virtual;
published
property helpContext: int read fldHelpContext write fldHelpContext;
property message: AnsiString read fldMessage write fldMessage;
end;
Exception = class(Throwable);
PropertyException = class(Exception);
PropertyNotFoundException = class(PropertyException);
IllegalPropertyTypeException = class(PropertyException);
IllegalPropertyAccessException = class(PropertyException);
RuntimeException = class(Exception);
ArithmeticException = class(RuntimeException);
ClassCastException = class(RuntimeException);
InstantiationException = class(RuntimeException);
IllegalStateException = class(RuntimeException);
IllegalMonitorStateException = class(IllegalStateException);
IllegalThreadStateException = class(IllegalStateException);
IllegalArgumentException = class(RuntimeException);
IllegalPropertyValueException = class(IllegalArgumentException);
NumberFormatException = class(IllegalArgumentException);
IndexOutOfBoundsException = class(RuntimeException);
ArrayIndexOutOfBoundsException = class(IndexOutOfBoundsException);
StringIndexOutOfBoundsException = class(IndexOutOfBoundsException);
NegativeArraySizeException = class(RuntimeException);
NullPointerException = class(RuntimeException);
SecurityException = class(RuntimeException);
SafecallException = class(RuntimeException);
UnsupportedOperationException = class(RuntimeException);
ReadOnlyPropertyException = class(UnsupportedOperationException);
WriteOnlyPropertyException = class(UnsupportedOperationException);
Error = class(Throwable);
ClassContentError = class(Error);
AbstractMethodError = class(ClassContentError);
BufferTooLargeError = class(Error);
MachineError = class(Error);
StackOverflowError = class(MachineError);
MemoryError = class(MachineError)
protected
fldFreeDisallowed: boolean;
procedure freeAllow(); virtual;
procedure freeDisallow(); virtual;
public
procedure freeInstance(); override;
end;
OutOfMemoryError = class(MemoryError);
InvalidPointerError = class(MemoryError);
AResource = class sealed
private
class procedure updateResourceStringReferences(); static;
public
class procedure setResourceString(const __unitName, rstrName, rstrValue: AnsiString); static;
class function getResourceString(const __unitName, rstrName: AnsiString): AnsiString; static;
class function unitToResourceName(const __unitName, rsrcName: AnsiString): AnsiString; static;
class function unitToTextResourceName(const __unitName, rsrcName: AnsiString): AnsiString; static;
class function readResourceAsAnsiString(const rsrcName: AnsiString): AnsiString; static;
class function readUnitResourceAsAnsiString(const __unitName, rstrName: AnsiString): AnsiString; static;
end;
Lang = class sealed
{
0 1 2 3 4
0 tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
5 tkSet, tkMethod, tkSString, tkLString, tkAString,
10 tkWString, tkVariant, tkArray, tkRecord, tkInterface,
15 tkClass, tkObject, tkWChar, tkBool, tkInt64,
20 tkQWord, tkDynArray, tkInterfaceRaw, tkProcVar, tkUString,
25 tkUChar, tkHelper, tkFile, tkClassRef, tkPointer
0 1 2 3
30 otSByte, otUByte, otSWord, otUWord,
34 otSLong, otULong, otSQWord, otUQWord
38 ftSingle, ftDouble, ftExtended, ftComp,
42 ftCurr
}
private
class function getGuidIndex(const guid: system.TGuid; capacity: int): int; static;
public const
{ === primitive types === }
TYPE_BOOLEAN = int(18);
TYPE_CHAR = int(2);
TYPE_UCHAR = int(17);
TYPE_BYTE = int(30);
TYPE_SHORT = int(32);
TYPE_INT = int(1);
TYPE_LONG = int(19);
TYPE_UBYTE = int(31);
TYPE_USHORT = int(33);
TYPE_UINT = int(35);
TYPE_ULONG = int(20);
TYPE_FLOAT = int(4);
TYPE_DOUBLE = int(39);
TYPE_REAL = int(40);
TYPE_COMP = int(41);
TYPE_CURRENCY = int(42);
TYPE_ENUMERATION = int(3);
{ === pointer types === }
TYPE_POINTER = int(29);
TYPE_CLASS = int(15);
TYPE_CLASSREF = int(28);
TYPE_INTERFACE_RC = int(14);
TYPE_INTERFACE_RAW = int(22);
TYPE_FUNCTION = int(23);
TYPE_ANSISTRING = int(9);
TYPE_WIDESTRING = int(10);
TYPE_UNICODESTRING = int(24);
TYPE_ARRAY_DYNAMIC = int(21);
{ === structured types === }
TYPE_UNKNOWN = int(0);
TYPE_SET = int(5);
TYPE_FILE = int(27);
TYPE_RECORD = int(13);
TYPE_OBJECT = int(16);
TYPE_METHOD = int(6);
TYPE_HELPER = int(26);
TYPE_VARIANT = int(11);
TYPE_SHORTSTRING = int(7);
TYPE_ARRAY_STATIC = int(12);
public
class procedure registerInterfaces(const iinfos: array of Pointer); static;
class function isType(const typRef, typIID: ShortString): boolean; static;
class function isType(const typRef, typIID: system.TGuid): boolean; static;
class function isInstance(objRef: ISimple; const typIID: ShortString): boolean; static;
class function isInstance(objRef: ISimple; const typIID: system.TGuid): boolean; static;
class function isInstance(objRef: ISimple; const typRef: system.TClass): boolean; static;
class function isInstance(objRef: IUnknown; const typIID: ShortString): boolean; static;
class function identityHashCode(objRef: TObject): long; static;
class function identityHashCode(objRef: ISimple): long; static;
class function identityHashCode(objRef: IUnknown): long; static;
class function cast(objRef: ISimple; const typIID: ShortString): ISimple; static;
class function cast(objRef: ISimple; const typIID: system.TGuid): IUnknown; static;
class function cast(objRef: ISimple; const typRef: system.TClass): TObject; static;
class function cast(objRef: IUnknown; const typIID: ShortString): ISimple; static;
class function classFor(const typIID: ShortString): &Class; static;
class function classFor(const typIID: system.TGuid): &Class; static;
class function classFor(const typRef: system.TClass): &Class; static;
class function classFor(tinfo: Pointer): &Class; static;
end;
Math = class sealed
strict private const
ROUND_TO_NEAREST = int($0000);
ROUND_DOWN = int($0400);
ROUND_UP = int($0800);
ROUND_TOWARD_ZERO = int($0c00);
private
class procedure setRoundMode(mode: int); static;
{$IFDEF WINDOWS}
public
class function E: real; static;
class function PI: real; static;
class function LOG_2_10: real; static;
class function LOG_2_E: real; static;
class function LOG_10_2: real; static;
class function LOG_E_2: real; static;
{$ELSE}
public const
E = real(2.7182818284590452354);
PI = real(3.1415926535897932386);
LOG_2_10 = real(3.3219280948873623478);
LOG_2_E = real(1.4426950408889634074);
LOG_10_2 = real(0.30102999566398119522);
LOG_E_2 = real(0.69314718055994530945);
{$ENDIF}
public
class function abs(x: int): int; static;
class function abs(x: long): long; static;
class function abs(x: float): float; static;
class function abs(x: double): double; static;
class function abs(x: real): real; static;
class function sin(x: real): real; static;
class function cos(x: real): real; static;
class function tan(x: real): real; static;
class function asin(x: real): real; static;
class function acos(x: real): real; static;
class function atan(x: real): real; static;
class function exp(x: real): real; static;
class function exp2(x: real): real; static;
class function exp10(x: real): real; static;
class function log(x: real): real; static;
class function log2(x: real): real; static;
class function log10(x: real): real; static;
class function sqrt(x: real): real; static;
class function cbrt(x: real): real; static;
class function sinh(x: real): real; static;
class function cosh(x: real): real; static;
class function tanh(x: real): real; static;
class function asinh(x: real): real; static;
class function acosh(x: real): real; static;
class function atanh(x: real): real; static;
class function ceil(x: real): real; static;
class function floor(x: real): real; static;
class function round(x: real): real; static;
class function intPart(x: real): real; static;
class function fracPart(x: real): real; static;
class function atan2(x, y: real): real; static;
class function pow(x, y: real): real; static;
class function toRadians(angleInDegrees: real): real; static;
class function toDegrees(angleInRadians: real): real; static;
end;
&Array = class sealed
private
class procedure copyBy1(const src; var dst; length: long); static;
class procedure copyBy2(const src; var dst; length: long); static;
class procedure copyBy4(const src; var dst; length: long); static;
class procedure copyBy8(const src; var dst; length: long); static;
class procedure fillReal(var dst; length: int; const value: real); static;
class procedure fillLong(var dst; size, length: int; value: long); static;
class function findfeq(const src; size, length: int; value: long): int; static;
class function findfne(const src; size, length: int; value: long): int; static;
class function findbeq(const src; size, length: int; value: long): int; static;
class function findbne(const src; size, length: int; value: long): int; static;
class function compfeq(const src1, src2; size, length: int): int; static;
class function compfne(const src1, src2; size, length: int): int; static;
class function compbeq(const src1, src2; size, length: int): int; static;
class function compbne(const src1, src2; size, length: int): int; static;
public const
NOT_FOUND = int(-$80000000);
public
class procedure checkBounds(const aarray; offset, length: int); static;
class procedure copyRaw(const src; var dst; length: long); static;
class procedure copyPrimitives(const srcArray: boolean_Array1d; srcOffset: int; const dstArray: boolean_Array1d; dstOffset: int; length: int); static;
class procedure copyPrimitives(const srcArray: char_Array1d; srcOffset: int; const dstArray: char_Array1d; dstOffset: int; length: int); static;
class procedure copyPrimitives(const srcArray: uchar_Array1d; srcOffset: int; const dstArray: uchar_Array1d; dstOffset: int; length: int); static;
class procedure copyPrimitives(const srcArray: byte_Array1d; srcOffset: int; const dstArray: byte_Array1d; dstOffset: int; length: int); static;
class procedure copyPrimitives(const srcArray: short_Array1d; srcOffset: int; const dstArray: short_Array1d; dstOffset: int; length: int); static;
class procedure copyPrimitives(const srcArray: int_Array1d; srcOffset: int; const dstArray: int_Array1d; dstOffset: int; length: int); static;
class procedure copyPrimitives(const srcArray: long_Array1d; srcOffset: int; const dstArray: long_Array1d; dstOffset: int; length: int); static;
class procedure copyPrimitives(const srcArray: float_Array1d; srcOffset: int; const dstArray: float_Array1d; dstOffset: int; length: int); static;
class procedure copyPrimitives(const srcArray: double_Array1d; srcOffset: int; const dstArray: double_Array1d; dstOffset: int; length: int); static;
class procedure copyPrimitives(const srcArray: real_Array1d; srcOffset: int; const dstArray: real_Array1d; dstOffset: int; length: int); static;
class procedure copyStrings(const srcArray: AnsiString_Array1d; srcOffset: int; const dstArray: AnsiString_Array1d; dstOffset: int; length: int); static;
class procedure copyStrings(const srcArray: UnicodeString_Array1d; srcOffset: int; const dstArray: UnicodeString_Array1d; dstOffset: int; length: int); static;
class procedure copyObjects(const srcArray; srcOffset: int; const dstArray; dstOffset: int; length: int); static;
class procedure copySimples(const srcArray; srcOffset: int; const dstArray; dstOffset: int; length: int); static;
class procedure copyUnknowns(const srcArray; srcOffset: int; const dstArray; dstOffset: int; length: int); static;
class procedure copyArrays(const srcArray; srcOffset: int; const dstArray; dstOffset: int; length: int); static;
class procedure zeroRaw(out dst; length: long); static;
class procedure fillPrimitives(const dstArray: boolean_Array1d; dstOffset: int; length: int; value: boolean); static;
class procedure fillPrimitives(const dstArray: char_Array1d; dstOffset: int; length: int; value: char); static;
class procedure fillPrimitives(const dstArray: uchar_Array1d; dstOffset: int; length: int; value: uchar); static;
class procedure fillPrimitives(const dstArray: byte_Array1d; dstOffset: int; length: int; value: byte); static;
class procedure fillPrimitives(const dstArray: short_Array1d; dstOffset: int; length: int; value: short); static;
class procedure fillPrimitives(const dstArray: int_Array1d; dstOffset: int; length: int; value: int); static;
class procedure fillPrimitives(const dstArray: long_Array1d; dstOffset: int; length: int; value: long); static;
class procedure fillPrimitives(const dstArray: float_Array1d; dstOffset: int; length: int; value: float); static;
class procedure fillPrimitives(const dstArray: double_Array1d; dstOffset: int; length: int; value: double); static;
class procedure fillPrimitives(const dstArray: real_Array1d; dstOffset: int; length: int; value: real); static;
class procedure fillStrings(const dstArray: AnsiString_Array1d; dstOffset: int; length: int; const value: AnsiString); static;
class procedure fillStrings(const dstArray: UnicodeString_Array1d; dstOffset: int; length: int; const value: UnicodeString); static;
class procedure fillObjects(const dstArray; dstOffset: int; length: int; value: TObject); static;
class procedure fillSimples(const dstArray; dstOffset: int; length: int; value: ISimple); static;
class procedure fillUnknowns(const dstArray; dstOffset: int; length: int; value: IUnknown); static;
class procedure fillArrays(const dstArray; dstOffset: int; length: int; const value); static;
class function indexOf(value: boolean; const aarray: boolean_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOf(value: char; const aarray: char_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOf(value: uchar; const aarray: uchar_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOf(value: int; const aarray: byte_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOf(value: int; const aarray: short_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOf(value: int; const aarray: int_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOf(value: long; const aarray: long_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOf(value: Pointer; const aarray; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOf(value: boolean; const aarray: boolean_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOf(value: char; const aarray: char_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOf(value: uchar; const aarray: uchar_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOf(value: int; const aarray: byte_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOf(value: int; const aarray: short_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOf(value: int; const aarray: int_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOf(value: long; const aarray: long_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOf(value: Pointer; const aarray; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOfNon(value: boolean; const aarray: boolean_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOfNon(value: char; const aarray: char_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOfNon(value: uchar; const aarray: uchar_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOfNon(value: int; const aarray: byte_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOfNon(value: int; const aarray: short_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOfNon(value: int; const aarray: int_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOfNon(value: long; const aarray: long_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function indexOfNon(value: Pointer; const aarray; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOfNon(value: boolean; const aarray: boolean_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOfNon(value: char; const aarray: char_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOfNon(value: uchar; const aarray: uchar_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOfNon(value: int; const aarray: byte_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOfNon(value: int; const aarray: short_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOfNon(value: int; const aarray: int_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOfNon(value: long; const aarray: long_Array1d; startFromIndex: int; maximumScanLength: int): int; static;
class function lastIndexOfNon(value: Pointer; const aarray; startFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfEqual(const array1: boolean_Array1d; array1StartFromIndex: int; const array2: boolean_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfEqual(const array1: char_Array1d; array1StartFromIndex: int; const array2: char_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfEqual(const array1: uchar_Array1d; array1StartFromIndex: int; const array2: uchar_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfEqual(const array1: byte_Array1d; array1StartFromIndex: int; const array2: byte_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfEqual(const array1: short_Array1d; array1StartFromIndex: int; const array2: short_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfEqual(const array1: int_Array1d; array1StartFromIndex: int; const array2: int_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfEqual(const array1: long_Array1d; array1StartFromIndex: int; const array2: long_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfEqualPtr(const array1; array1StartFromIndex: int; const array2; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfNonEqual(const array1: boolean_Array1d; array1StartFromIndex: int; const array2: boolean_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfNonEqual(const array1: char_Array1d; array1StartFromIndex: int; const array2: char_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfNonEqual(const array1: uchar_Array1d; array1StartFromIndex: int; const array2: uchar_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfNonEqual(const array1: byte_Array1d; array1StartFromIndex: int; const array2: byte_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfNonEqual(const array1: short_Array1d; array1StartFromIndex: int; const array2: short_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfNonEqual(const array1: int_Array1d; array1StartFromIndex: int; const array2: int_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfNonEqual(const array1: long_Array1d; array1StartFromIndex: int; const array2: long_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function offsetOfNonEqualPtr(const array1; array1StartFromIndex: int; const array2; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfEqual(const array1: boolean_Array1d; array1StartFromIndex: int; const array2: boolean_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfEqual(const array1: char_Array1d; array1StartFromIndex: int; const array2: char_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfEqual(const array1: uchar_Array1d; array1StartFromIndex: int; const array2: uchar_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfEqual(const array1: byte_Array1d; array1StartFromIndex: int; const array2: byte_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfEqual(const array1: short_Array1d; array1StartFromIndex: int; const array2: short_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfEqual(const array1: int_Array1d; array1StartFromIndex: int; const array2: int_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfEqual(const array1: long_Array1d; array1StartFromIndex: int; const array2: long_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfEqualPtr(const array1; array1StartFromIndex: int; const array2; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfNonEqual(const array1: boolean_Array1d; array1StartFromIndex: int; const array2: boolean_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfNonEqual(const array1: char_Array1d; array1StartFromIndex: int; const array2: char_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfNonEqual(const array1: uchar_Array1d; array1StartFromIndex: int; const array2: uchar_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfNonEqual(const array1: byte_Array1d; array1StartFromIndex: int; const array2: byte_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfNonEqual(const array1: short_Array1d; array1StartFromIndex: int; const array2: short_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfNonEqual(const array1: int_Array1d; array1StartFromIndex: int; const array2: int_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfNonEqual(const array1: long_Array1d; array1StartFromIndex: int; const array2: long_Array1d; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function negOffsetOfNonEqualPtr(const array1; array1StartFromIndex: int; const array2; array2StartFromIndex: int; maximumScanLength: int): int; static;
class function newBoolean1d(length: int): boolean_Array1d; static;
class function newBoolean1d(const components: array of boolean): boolean_Array1d; static;
class function newChar1d(length: int): char_Array1d; static;
class function newChar1d(const components: array of char): char_Array1d; static;
class function newUChar1d(length: int): uchar_Array1d; static;
class function newUChar1d(const components: array of uchar): uchar_Array1d; static;
class function newByte1d(length: int): byte_Array1d; static;
class function newByte1d(const components: array of byte): byte_Array1d; static;
class function newShort1d(length: int): short_Array1d; static;
class function newShort1d(const components: array of short): short_Array1d; static;
class function newInt1d(length: int): int_Array1d; static;
class function newInt1d(const components: array of int): int_Array1d; static;
class function newLong1d(length: int): long_Array1d; static;
class function newLong1d(const components: array of long): long_Array1d; static;
class function newFloat1d(length: int): float_Array1d; static;
class function newFloat1d(const components: array of float): float_Array1d; static;
class function newDouble1d(length: int): double_Array1d; static;
class function newDouble1d(const components: array of double): double_Array1d; static;
class function newReal1d(length: int): real_Array1d; static;
class function newReal1d(const components: array of real): real_Array1d; static;
class function newAnsiString1d(length: int): AnsiString_Array1d; static;
class function newAnsiString1d(const components: array of AnsiString): AnsiString_Array1d; static;
class function newUnicodeString1d(length: int): UnicodeString_Array1d; static;
class function newUnicodeString1d(const components: array of UnicodeString): UnicodeString_Array1d; static;
class function newPointer1d(length: int): Pointer_Array1d; static;
class function newPointer1d(const components: array of Pointer): Pointer_Array1d; static;
class function newTObject1d(length: int): TObject_Array1d; static;
class function newTObject1d(const components: array of TObject): TObject_Array1d; static;
class function newISimple1d(length: int): ISimple_Array1d; static;
class function newISimple1d(const components: array of ISimple): ISimple_Array1d; static;
class function newIUnknown1d(length: int): IUnknown_Array1d; static;
class function newIUnknown1d(const components: array of IUnknown): IUnknown_Array1d; static;
class function newBoolean2d(length: int): boolean_Array2d; static;
class function newBoolean2d(length1, length2: int): boolean_Array2d; static;
class function newBoolean2d(const components: array of boolean_Array1d): boolean_Array2d; static;
class function newChar2d(length: int): char_Array2d; static;
class function newChar2d(length1, length2: int): char_Array2d; static;
class function newChar2d(const components: array of char_Array1d): char_Array2d; static;
class function newUChar2d(length: int): uchar_Array2d; static;
class function newUChar2d(length1, length2: int): uchar_Array2d; static;
class function newUChar2d(const components: array of uchar_Array1d): uchar_Array2d; static;
class function newByte2d(length: int): byte_Array2d; static;
class function newByte2d(length1, length2: int): byte_Array2d; static;
class function newByte2d(const components: array of byte_Array1d): byte_Array2d; static;
class function newShort2d(length: int): short_Array2d; static;
class function newShort2d(length1, length2: int): short_Array2d; static;
class function newShort2d(const components: array of short_Array1d): short_Array2d; static;
class function newInt2d(length: int): int_Array2d; static;
class function newInt2d(length1, length2: int): int_Array2d; static;
class function newInt2d(const components: array of int_Array1d): int_Array2d; static;
class function newLong2d(length: int): long_Array2d; static;
class function newLong2d(length1, length2: int): long_Array2d; static;
class function newLong2d(const components: array of long_Array1d): long_Array2d; static;
class function newFloat2d(length: int): float_Array2d; static;
class function newFloat2d(length1, length2: int): float_Array2d; static;
class function newFloat2d(const components: array of float_Array1d): float_Array2d; static;
class function newDouble2d(length: int): double_Array2d; static;
class function newDouble2d(length1, length2: int): double_Array2d; static;
class function newDouble2d(const components: array of double_Array1d): double_Array2d; static;
class function newReal2d(length: int): real_Array2d; static;
class function newReal2d(length1, length2: int): real_Array2d; static;
class function newReal2d(const components: array of real_Array1d): real_Array2d; static;
class function newAnsiString2d(length: int): AnsiString_Array2d; static;
class function newAnsiString2d(length1, length2: int): AnsiString_Array2d; static;
class function newAnsiString2d(const components: array of AnsiString_Array1d): AnsiString_Array2d; static;
class function newUnicodeString2d(length: int): UnicodeString_Array2d; static;
class function newUnicodeString2d(length1, length2: int): UnicodeString_Array2d; static;
class function newUnicodeString2d(const components: array of UnicodeString_Array1d): UnicodeString_Array2d; static;
class function newPointer2d(length: int): Pointer_Array2d; static;
class function newPointer2d(length1, length2: int): Pointer_Array2d; static;
class function newPointer2d(const components: array of Pointer_Array1d): Pointer_Array2d; static;
class function newTObject2d(length: int): TObject_Array2d; static;
class function newTObject2d(length1, length2: int): TObject_Array2d; static;
class function newTObject2d(const components: array of TObject_Array1d): TObject_Array2d; static;
class function newISimple2d(length: int): ISimple_Array2d; static;
class function newISimple2d(length1, length2: int): ISimple_Array2d; static;
class function newISimple2d(const components: array of ISimple_Array1d): ISimple_Array2d; static;
class function newIUnknown2d(length: int): IUnknown_Array2d; static;
class function newIUnknown2d(length1, length2: int): IUnknown_Array2d; static;
class function newIUnknown2d(const components: array of IUnknown_Array1d): IUnknown_Array2d; static;
end;
TObjectExtended = class helper for TObject
private const
TM_FIELD = int(0);
TM_SPECIAL = int(1);
TM_VIRTUAL = int(2);
TM_CONST = int(3);
private
class function getPropertyInfo(const name: AnsiString): PPropInfo;
public
procedure writePropertyOfBoolean(const name: AnsiString; const value: boolean);
procedure writePropertyOfLong(const name: AnsiString; const value: long);
procedure writePropertyOfDouble(const name: AnsiString; const value: double);
procedure writePropertyOfAnsiString(const name: AnsiString; const value: AnsiString);
procedure writePropertyOfUnicodeString(const name: AnsiString; const value: UnicodeString);
procedure writePropertyOfObject(const name: AnsiString; const value: TObject);
procedure writePropertyOfSimple(const name: AnsiString; const value: ISimple);
procedure writePropertyOfUnknown(const name: AnsiString; const value: IUnknown);
function isStoredProperty(const name: AnsiString): boolean;
function readPropertyOfBoolean(const name: AnsiString): boolean;
function readPropertyOfLong(const name: AnsiString): long;
function readPropertyOfDouble(const name: AnsiString): double;
function readPropertyOfAnsiString(const name: AnsiString): AnsiString;
function readPropertyOfUnicodeString(const name: AnsiString): UnicodeString;
function readPropertyOfObject(const name: AnsiString): TObject;
function readPropertyOfSimple(const name: AnsiString): ISimple;
function readPropertyOfUnknown(const name: AnsiString): IUnknown;
function getClass(): &Class;
end;
ISimpleExtended = type helper for ISimple
public
function getClass(): &Class;
end;
IUnknownExtended = type helper for IUnknown
public
function getClass(): &Class;
end;
AnsiStringExtended = type helper for AnsiString
public
class function create(length: int): AnsiString; static;
class function create(const src: byte_Array1d): AnsiString; static;
class function create(const src: char_Array1d): AnsiString; static;
class function create(const src: byte_Array1d; offset, length: int): AnsiString; static;
class function create(const src: char_Array1d; offset, length: int): AnsiString; static;
class function create(const charCodes: int_Array1d; offset, length: int): AnsiString; static;
class function format(const form: AnsiString; const data: array of Value): AnsiString; static;
private
function getLength(): int;
public
procedure getChars(beginIndex, endIndex: int; const dst: char_Array1d; offset: int);
function startsWith(const prefix: AnsiString; position: int = 1): boolean;
function endsWith(const suffix: AnsiString): boolean;
function indexOf(const prefix: AnsiString; startFromIndex: int = 1): int;
function lastIndexOf(const prefix: AnsiString; startFromIndex: int = int(CoInt.MAX_VALUE + 1)): int;
function replaceAll(oldCharacter, newCharacter: char): AnsiString;
function copy(): AnsiString;
function copy(beginIndex: int): AnsiString;
function copy(beginIndex, endIndex: int): AnsiString;
function trim(): AnsiString;
function substring(beginIndex: int): AnsiString;
function substring(beginIndex, endIndex: int): AnsiString;
function toLowerCase(): AnsiString;
function toUpperCase(): AnsiString;
function toUTF16(): UnicodeString;
function toByteArray(): byte_Array1d;
function toCharArray(): char_Array1d;
function toCharCodes(): int_Array1d;
function split(): AnsiString_Array1d;
property length: int read getLength;
end;
UnicodeStringExtended = type helper for UnicodeString
public
class function create(length: int): UnicodeString; static;
class function create(const src: short_Array1d): UnicodeString; static;
class function create(const src: uchar_Array1d): UnicodeString; static;
class function create(const src: short_Array1d; offset, length: int): UnicodeString; static;
class function create(const src: uchar_Array1d; offset, length: int): UnicodeString; static;
class function create(const charCodes: int_Array1d; offset, length: int): UnicodeString; static;
class function format(const form: UnicodeString; const data: array of Value): UnicodeString; static;
private
function getLength(): int;
public
procedure getChars(beginIndex, endIndex: int; const dst: uchar_Array1d; offset: int);
function equalsIgnoreCase(const anot: UnicodeString): boolean;
function startsWith(const prefix: UnicodeString; position: int = 1): boolean;
function endsWith(const suffix: UnicodeString): boolean;
function indexOf(const prefix: UnicodeString; startFromIndex: int = 1): int;
function lastIndexOf(const prefix: UnicodeString; startFromIndex: int = int(CoInt.MAX_VALUE + 1)): int;
function replaceAll(oldCharacter, newCharacter: uchar): UnicodeString;
function copy(): UnicodeString;
function copy(beginIndex: int): UnicodeString;
function copy(beginIndex, endIndex: int): UnicodeString;
function trim(): UnicodeString;
function substring(beginIndex: int): UnicodeString;
function substring(beginIndex, endIndex: int): UnicodeString;
function toLowerCase(): UnicodeString;
function toUpperCase(): UnicodeString;
function toUTF8(): AnsiString;
function toShortArray(): short_Array1d;
function toUCharArray(): uchar_Array1d;
function toCharCodes(): int_Array1d;
function split(): UnicodeString_Array1d;
property length: int read getLength;
end;
{%endregion}
{%region real operators (Windows only)}
{$IFDEF WINDOWS}
operator :=(value: long): real;
operator :=(value: double): real;
operator +(const value: real): real;
operator -(const value: real): real;
operator +(const value1, value2: real): real;
operator -(const value1, value2: real): real;
operator *(const value1, value2: real): real;
operator /(const value1, value2: real): real;
operator =(const value1, value2: real): boolean;
operator >(const value1, value2: real): boolean;
operator <(const value1, value2: real): boolean;
operator <>(const value1, value2: real): boolean;
operator <=(const value1, value2: real): boolean;
operator >=(const value1, value2: real): boolean;
{$ENDIF}
{%endregion}
implementation
{%region} uses
pascalx.io.charset.basiclatin,
pascalx.lang.locale;
{%endregion}
{$R *.res}
{$WARN 7104 OFF} { позволить обращение к локальным переменным через [rbp-<смещение>] }
{$WARN 7105 OFF} { позволить использовать инструкцию lea rsp, [rsp-<смещение>] чтобы уменьшить значение регистра указателя стака }
{$WARN 7120 OFF} { позволить не указывать размер операндов памяти для инструкций SSE и AVX в тех случаях, когда это необязательно }
{$WARN 7121 OFF}
{$WARN 7122 OFF}
{$WARN 7123 OFF} { позволить отрицательные смещения в операндах памяти }
{$ASMMODE INTEL}
{$TYPEINFO OFF}
{$CALLING REGISTER}
{%region} type
Pint = ^int;
PFXContext = ^FXContext;
PResourceStringInitEntry = ^ResourceStringInitEntry;
PResourceStringInitList = ^ResourceStringInitList;
PResourceStringList = ^ResourceStringList;
PResourceStringStruct = ^ResourceStringStruct;
PPResourceStringStruct = ^PResourceStringStruct;
TypeInformation = class;
PointerTypeInformation = class;
PrimitiveTypeInformation = class;
ClassTypeInformation = class;
ClassRefTypeInformation = class;
InterfaceTypeInformation = class;
DynamicArrayTypeInformation = class;
FunctionTypeInformation = class;
StructuredTypeInformation = class;
PropertyInformation = class;
ThreadCollection = class;
InterfaceEntry = class;
ThreadEntry = class;
int2 = packed array [0..1] of int;
int4 = packed array [0..3] of int;
long2 = packed array [0..1] of long;
{ InterfaceEntry[] } InterfaceEntry_Array1d = specialize DynamicArray<InterfaceEntry>;
{ ThreadEntry[] } ThreadEntry_Array1d = specialize DynamicArray<ThreadEntry>;
{ int2[] } int2_Array1d = specialize DynamicArray<int2>;
{$IFDEF WINDOWS}
FunctionGetExceptionObject = function(errorNumber: int; const rec: windows.TExceptionRecord): TObject;
FunctionGetExceptionClass = function(errorNumber: int): TClass;
{$ENDIF}
FXContext = packed record
fcw: short;
fsw: short;
ftw: byte; __reserved005: byte;
fop: short;
fip: long;
fdp: long;
mxcsr: int;
mxcsrMask: int;
st0: real; __reserved02A: packed array [0..5] of byte;
st1: real; __reserved03A: packed array [0..5] of byte;
st2: real; __reserved04A: packed array [0..5] of byte;
st3: real; __reserved05A: packed array [0..5] of byte;
st4: real; __reserved06A: packed array [0..5] of byte;
st5: real; __reserved07A: packed array [0..5] of byte;
st6: real; __reserved08A: packed array [0..5] of byte;
st7: real; __reserved09A: packed array [0..5] of byte;
case int of
0: (
xmm0: long2;
xmm1: long2;
xmm2: long2;
xmm3: long2;
xmm4: long2;
xmm5: long2;
xmm6: long2;
xmm7: long2;
xmm8: long2;
xmm9: long2;
xmm10: long2;
xmm11: long2;
xmm12: long2;
xmm13: long2;
xmm14: long2;
xmm15: long2;
);
1: (
xmm: packed array [0..15] of long2;
__reserved1A0: packed array [0..$2f] of byte;
available: packed array [0..$2f] of byte;
);
end;
RealStruct = packed record
case int of
0: (
significand: long;
exponent: short;
);
1: (
bytes: packed array [0..9] of system.UInt8;
);
2: (
words: packed array [0..4] of system.UInt16;
);
3: (
value: real;
);
end;
ResourceStringInitEntry = packed record
address: Pointer;
data: PResourceStringStruct;
end;
ResourceStringInitList = packed record
length: long;
list: packed array [0..0] of PResourceStringInitEntry;
end;
ResourceStringTable = packed record
start: PPResourceStringStruct;
finish: PPResourceStringStruct;
end;
ResourceStringList = packed record
length: long;
list: packed array [0..0] of ResourceStringTable;
end;
ResourceStringStruct = packed record
name: AnsiString;
value: AnsiString;
default: AnsiString;
hash: int;
__reserved1C: int;
end;
TypeInformation = class abstract(RefCountObject, &Class)
protected
fldInfo: PTypeInfo;
fldData: PTypeData;
public
constructor create(info: PTypeInfo);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function isPointer(): boolean; virtual; abstract;
function isPrimitive(): boolean; virtual; abstract;
function isInstance(ref: TObject): boolean; virtual;
function isInstance(ref: ISimple): boolean; virtual;
function isInstance(ref: IUnknown): boolean; virtual;
function isAssignableFrom(cls: &Class): boolean; virtual;
function getTypeKind(): int; virtual;
function getUnitName(): AnsiString; virtual;
function getSimpleName(): AnsiString; virtual;
function getOriginalUnit(): AnsiString; virtual;
function getOriginalName(): AnsiString;
function getCanonicalName(): AnsiString;
function getProperties(): Property_Array1d; virtual;
function getInterfaces(): Class_Array1d; virtual;
function getProperty(const name: AnsiString): &Property; virtual;
function getSuperclass(): &Class; virtual;
function getReference(): &Class; virtual;
function getComponentType(): &Class; virtual;
function createInstance(): DynamicObject; virtual;
end;
PrimitiveTypeInformation = class sealed(TypeInformation)
private
fldKind: int;
fldName: AnsiString;
public
constructor create(info: PTypeInfo; kind: int; const name: AnsiString);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function isPointer(): boolean; override;
function isPrimitive(): boolean; override;
function isAssignableFrom(cls: &Class): boolean; override;
function getTypeKind(): int; override;
function getSimpleName(): AnsiString; override;
end;
PointerTypeInformation = class(TypeInformation)
public
function isPointer(): boolean; override; final;
function isPrimitive(): boolean; override; final;
end;
ClassTypeInformation = class sealed(PointerTypeInformation)
private
class function typeInfoToLangType(tinfo: PTypeInfo): int; static;
class function propInfoToProperty(pinfo: PPropInfo): &Property; static;
private
fldType: TClass;
public
constructor create(info: TClass);
constructor create(info: PTypeInfo);
function toString(): AnsiString; override;
function isInstance(ref: TObject): boolean; override;
function isInstance(ref: ISimple): boolean; override;
function isInstance(ref: IUnknown): boolean; override;
function isAssignableFrom(cls: &Class): boolean; override;
function getTypeKind(): int; override;
function getOriginalUnit(): AnsiString; override;
function getProperties(): Property_Array1d; override;
function getInterfaces(): Class_Array1d; override;
function getProperty(const name: AnsiString): &Property; override;
function getSuperclass(): &Class; override;
function createInstance(): DynamicObject; override;
end;
ClassRefTypeInformation = class sealed(PointerTypeInformation)
private
fldType: TClass;
public
constructor create(info: PTypeInfo);
function toString(): AnsiString; override;
function isAssignableFrom(cls: &Class): boolean; override;
function getTypeKind(): int; override;
function getReference(): &Class; override;
end;
InterfaceTypeInformation = class sealed(PointerTypeInformation)
public
function toString(): AnsiString; override;
function isInstance(ref: TObject): boolean; override;
function isInstance(ref: ISimple): boolean; override;
function isInstance(ref: IUnknown): boolean; override;
function isAssignableFrom(cls: &Class): boolean; override;
function getOriginalUnit(): AnsiString; override;
function getInterfaces(): Class_Array1d; override;
end;
DynamicArrayTypeInformation = class sealed(PointerTypeInformation)
private
fldComponent: PTypeInfo;
public
constructor create(info: PTypeInfo);
function toString(): AnsiString; override;
function isAssignableFrom(cls: &Class): boolean; override;
function getTypeKind(): int; override;
function getUnitName(): AnsiString; override;
function getSimpleName(): AnsiString; override;
function getOriginalUnit(): AnsiString; override;
function getComponentType(): &Class; override;
end;
FunctionTypeInformation = class sealed(PointerTypeInformation)
public
function isAssignableFrom(cls: &Class): boolean; override;
function getTypeKind(): int; override;
end;
StructuredTypeInformation = class(TypeInformation)
public
function isPointer(): boolean; override; final;
function isPrimitive(): boolean; override; final;
end;
PropertyInformation = class sealed(RefCountObject, &Property)
private
fldFlags: int;
fldName: AnsiString;
fldType: &Class;
public
constructor create(readable, writeable, storeable: boolean; &type: &Class; const name: AnsiString);
function isReadable(): boolean;
function isWriteable(): boolean;
function isStoreable(): boolean;
function getName(): AnsiString;
function getType(): &Class;
end;
ThreadCollection = class sealed(RefCountObject, Thread_Collection1d)
private
fldThreads: Thread_Array1d;
public
constructor create(const threads: Thread_Array1d);
destructor destroy; override;
procedure copyInto(const dstArray; dstOffset: int);
function getLength(): int;
function componentAt(index: int): Thread;
function toArray(): Thread_Array1d;
end;
InterfaceEntry = class sealed(&Object)
public
constructor create(const guid: system.TGuid; info: PTypeInfo; next: InterfaceEntry);
public
guid: system.TGuid;
info: PTypeInfo;
next: InterfaceEntry;
end;
ThreadEntry = class sealed(&Object)
public
constructor create(const threadId1, threadId2: long; threadRef: Thread; next: ThreadEntry);
destructor destroy; override;
public
threadId1: long;
threadId2: long;
event: long;
next: ThreadEntry;
threadRef: Thread;
threadOld: Thread;
end;
{%endregion}
{%region} var
ints: packed array [0..2] of int = (
int($80000000),
int($ffffc000),
int($00004000)
);
longs: packed array [0..5] of long = (
long($000000007fffffff),
long($7fffffffffffffff),
long($8000000000000000),
long($ffffffffffffffff),
long($ffffffff80000000),
long($0000000080000000)
);
floats: packed array [0..2] of float = (
2.14748365e+09,
9.22337204e+18,
CoFloat.NAN
);
doubles: packed array [0..1] of double = (
2.14748364800000000e+009,
9.22337203685477581e+018
);
int4s: packed array [0..0] of int4 = (
( int($7fffffff), int(0), int(0), int(0) )
);
long2s: packed array [0..0] of long2 = (
( long($7fffffffffffffff), long(0) )
);
reals: packed array [0..59] of RealStruct = (
( significand: long($8000000000000000); exponent: short($bfff) ), { –1.0 }
( significand: long($aaaaaaaaaaaaaaab); exponent: short($3ffd) ), { 1.0 / 3.0 }
( significand: long($8000000000000000); exponent: short($3ffe) ), { 1.0 / 2.0 }
( significand: long($c90fdaa22168c235); exponent: short($4001) ), { 2.0 * π }
( significand: long($e52ee0d31e0fbdc3); exponent: short($4004) ), { 180.0 / π }
( significand: long($a000000000000000); exponent: short($4002) ), { 1.e+0001 }
( significand: long($c800000000000000); exponent: short($4005) ), { 1.e+0002 }
( significand: long($fa00000000000000); exponent: short($4008) ), { 1.e+0003 }
( significand: long($9c40000000000000); exponent: short($400c) ), { 1.e+0004 }
( significand: long($c350000000000000); exponent: short($400f) ), { 1.e+0005 }
( significand: long($f424000000000000); exponent: short($4012) ), { 1.e+0006 }
( significand: long($9896800000000000); exponent: short($4016) ), { 1.e+0007 }
( significand: long($bebc200000000000); exponent: short($4019) ), { 1.e+0008 }
( significand: long($ee6b280000000000); exponent: short($401c) ), { 1.e+0009 }
( significand: long($9502f90000000000); exponent: short($4020) ), { 1.e+0010 }
( significand: long($ba43b74000000000); exponent: short($4023) ), { 1.e+0011 }
( significand: long($e8d4a51000000000); exponent: short($4026) ), { 1.e+0012 }
( significand: long($9184e72a00000000); exponent: short($402a) ), { 1.e+0013 }
( significand: long($b5e620f480000000); exponent: short($402d) ), { 1.e+0014 }
( significand: long($e35fa931a0000000); exponent: short($4030) ), { 1.e+0015 }
( significand: long($8e1bc9bf04000000); exponent: short($4034) ), { 1.e+0016 }
( significand: long($b1a2bc2ec5000000); exponent: short($4037) ), { 1.e+0017 }
( significand: long($de0b6b3a76400000); exponent: short($403a) ), { 1.e+0018 }
( significand: long($8ac7230489e80000); exponent: short($403e) ), { 1.e+0019 }
( significand: long($ad78ebc5ac620000); exponent: short($4041) ), { 1.e+0020 }
( significand: long($d8d726b7177a8000); exponent: short($4044) ), { 1.e+0021 }
( significand: long($878678326eac9000); exponent: short($4048) ), { 1.e+0022 }
( significand: long($a968163f0a57b400); exponent: short($404b) ), { 1.e+0023 }
( significand: long($d3c21bcecceda100); exponent: short($404e) ), { 1.e+0024 }
( significand: long($84595161401484a0); exponent: short($4052) ), { 1.e+0025 }
( significand: long($a56fa5b99019a5c8); exponent: short($4055) ), { 1.e+0026 }
( significand: long($cecb8f27f4200f3a); exponent: short($4058) ), { 1.e+0027 }
( significand: long($813f3978f8940984); exponent: short($405c) ), { 1.e+0028 }
( significand: long($a18f07d736b90be5); exponent: short($405f) ), { 1.e+0029 }
( significand: long($c9f2c9cd04674edf); exponent: short($4062) ), { 1.e+0030 }
( significand: long($fc6f7c4045812296); exponent: short($4065) ), { 1.e+0031 }
( significand: long($9dc5ada82b70b59e); exponent: short($4069) ), { 1.e+0032 }
( significand: long($c2781f49ffcfa6d5); exponent: short($40d3) ), { 1.e+0064 }
( significand: long($efb3ab16c59b14a3); exponent: short($413d) ), { 1.e+0096 }
( significand: long($93ba47c980e98ce0); exponent: short($41a8) ), { 1.e+0128 }
( significand: long($b616a12b7fe617aa); exponent: short($4212) ), { 1.e+0160 }
( significand: long($e070f78d3927556b); exponent: short($427c) ), { 1.e+0192 }
( significand: long($8a5296ffe33cc930); exponent: short($42e7) ), { 1.e+0224 }
( significand: long($aa7eebfb9df9de8e); exponent: short($4351) ), { 1.e+0256 }
( significand: long($d226fc195c6a2f8c); exponent: short($43bb) ), { 1.e+0288 }
( significand: long($81842f29f2cce376); exponent: short($4426) ), { 1.e+0320 }
( significand: long($9fa42700db900ad2); exponent: short($4490) ), { 1.e+0352 }
( significand: long($c4c5e310aef8aa17); exponent: short($44fa) ), { 1.e+0384 }
( significand: long($f28a9c07e9b09c59); exponent: short($4564) ), { 1.e+0416 }
( significand: long($957a4ae1ebf7f3d4); exponent: short($45cf) ), { 1.e+0448 }
( significand: long($b83ed8dc0795a262); exponent: short($4639) ), { 1.e+0480 }
( significand: long($e319a0aea60e91c7); exponent: short($46a3) ), { 1.e+0512 }
( significand: long($c976758681750c17); exponent: short($4d48) ), { 1.e+1024 }
( significand: long($b2b8353b3993a7e4); exponent: short($53ed) ), { 1.e+1536 }
( significand: long($9e8b3b5dc53d5de5); exponent: short($5a92) ), { 1.e+2048 }
( significand: long($8ca554c020a1f0a6); exponent: short($6137) ), { 1.e+2560 }
( significand: long($f9895d25d88b5a8b); exponent: short($67db) ), { 1.e+3072 }
( significand: long($dd5dc8a2bf27f3f8); exponent: short($6e80) ), { 1.e+3584 }
( significand: long($c46052028a20979b); exponent: short($7525) ), { 1.e+4096 }
( significand: long($ae3511626ed559f0); exponent: short($7bca) ) { 1.e+4608 }
);
{$IFDEF WINDOWS}
previousGetExceptionObject: FunctionGetExceptionObject;
previousGetExceptionClass: FunctionGetExceptionClass;
{$ENDIF}
previousExceptionHandler: TErrorProc;
errorInvalidPointer: MemoryError;
errorOutOfMemory: MemoryError;
fpusseDefaultContext: FXContext;
primitives: Class_Array1d;
representReal: RealRepresenter;
representFloat: RealRepresenter;
representDouble: RealRepresenter;
registeredInterfacesLength: int;
registeredInterfacesEntries: InterfaceEntry_Array1d;
threadCounter: int = $007fffff;
threadLength: int;
threadEntries: ThreadEntry_Array1d;
threadOperation: Mutex;
resourcestringOverrides: AnsiString_Array1d;
resourcestringInits: PResourceStringInitList; external name '_FPC_ResStrInitTables';
resourcestringTables: PResourceStringList; external name '_FPC_ResourceStringTables';
{%endregion}
{%region OS API — thread}
{$IFDEF WINDOWS}
const
TH32CS_SNAPTHREAD = system.DWord($00000004);
{$PACKRECORDS C}
type
PThreadEntry32 = ^ThreadEntry32;
ThreadEntry32 = record
dwSize: system.DWord;
cntUsage: system.DWord;
th32ThreadId: system.DWord;
th32OwnerProcessID: system.DWord;
tpBasePri: system.LongInt;
tpDeltaPri: system.LongInt;
dwFlags: system.DWord;
end;
{$PACKRECORDS DEFAULT}
{$CALLING STDCALL}
function createToolhelp32Snapshot(dwFlags, th32ProcessID: system.DWord): system.THandle; external windows.KERNEL32 name 'CreateToolhelp32Snapshot';
function thread32First(hSnapshot: system.THandle; lpThreadEntry: PThreadEntry32): system.LongBool; external windows.KERNEL32 name 'Thread32First';
function thread32Next(hSnapshot: system.THandle; lpThreadEntry: PThreadEntry32): system.LongBool; external windows.KERNEL32 name 'Thread32Next';
function threadSetDescription(hThread: system.THandle; lpThreadDescription: system.PWideChar): system.HResult; external windows.KERNEL32 name 'SetThreadDescription';
function threadGetDescription(hThread: system.THandle; ppszThreadDescription: system.PPWideChar): system.HResult; external windows.KERNEL32 name 'GetThreadDescription';
function isDebuggerPresent(): system.LongBool; external windows.KERNEL32 name 'IsDebuggerPresent';
{$ELSE}
const
SYSCALL_NR_GETTID = long(186);
const
DT_DIR = int(4);
{$CALLING CDECL}
function threadSetDescription(__thread: unixtype.PThread_t; __description: system.PAnsiChar): int; external pthreads.LIBTHREADS name 'pthread_setname_np';
function threadGetDescription(__thread: unixtype.PThread_t; __description: system.PAnsiChar; __size: int): int; external pthreads.LIBTHREADS name 'pthread_getname_np';
function threadGetSchedParam(__thread: unixtype.PThread_t; __policy, __priority: Pint): int; external pthreads.LIBTHREADS name 'pthread_getschedparam';
function threadGetSelf(): unixtype.PThread_t; external pthreads.LIBTHREADS name 'pthread_self';
function threadTryJoin(__thread: unixtype.PThread_t; __retval: PPointer): int; external pthreads.LIBTHREADS name 'pthread_tryjoin_np';
function doSyscall(__sysnr: long): long; external name 'FPC_SYSCALL0';
{$ENDIF}
{$CALLING REGISTER}
procedure threadSleep(timeInMillis: long; timeInNanos: int);
{$IFNDEF WINDOWS}
var
callResult: int;
timeRequired: unixtype.TimeSpec;
timeRemaining: unixtype.TimeSpec;
{$ENDIF}
begin
if (timeInMillis < CoLong.MAX_VALUE) and (timeInNanos >= 500000) or (timeInMillis = 0) and (timeInNanos > 0) then inc(timeInMillis);
if timeInMillis > $fffffffe then timeInMillis := $fffffffe;
{$IFDEF WINDOWS}
windows.sleep(system.DWord(timeInMillis));
{$ELSE}
if timeInMillis = 0 then begin
system.threadSwitch();
exit;
end;
timeRequired.tv_sec := timeInMillis div 1000;
timeRequired.tv_nsec := 1000000 * (timeInMillis mod 1000);
timeRemaining.tv_sec := 0;
timeRemaining.tv_nsec := 0;
repeat
callResult := baseunix.fpNanoSleep(@timeRequired, @timeRemaining);
timeRequired := timeRemaining;
until (callResult <> -1) or (baseunix.fpGetErrNo() <> baseunix.ESysEINTR);
{$ENDIF}
end;
procedure threadSetPriority(threadId2: long; newPriority: int);
{$IFDEF WINDOWS}
var
threadHandle: system.THandle;
begin
if threadId2 < 0 then exit;
threadHandle := windows.openThread(windows.THREAD_SET_LIMITED_INFORMATION, false, system.DWord(threadId2));
if threadHandle = windows.INVALID_HANDLE_VALUE then exit;
try
case newPriority of
Thread.MIN_PRIORITY - 0:
newPriority := windows.THREAD_PRIORITY_IDLE;
Thread.LOW_PRIORITY - 1:
newPriority := windows.THREAD_PRIORITY_LOWEST;
Thread.LOW_PRIORITY - 0:
newPriority := windows.THREAD_PRIORITY_BELOW_NORMAL;
Thread.NORM_PRIORITY - 1..
Thread.NORM_PRIORITY + 1:
newPriority := windows.THREAD_PRIORITY_NORMAL;
Thread.HIGH_PRIORITY + 0:
newPriority := windows.THREAD_PRIORITY_ABOVE_NORMAL;
Thread.HIGH_PRIORITY + 1:
newPriority := windows.THREAD_PRIORITY_HIGHEST;
else
newPriority := windows.THREAD_PRIORITY_TIME_CRITICAL;
end;
windows.setThreadPriority(threadHandle, newPriority);
finally
windows.closeHandle(threadHandle);
end;
end
{$ELSE}
begin
end
{$ENDIF};
procedure threadSetDescription(threadId2: long; const newDescription: AnsiString);
{$IFDEF WINDOWS}
const
MS_VC_EXCEPTION = system.DWord($406d1388);
type
ThreadNameInfo = record
dwType: system.DWord;
szName: system.PAnsiChar;
dwThreadID: system.DWord;
dwFlags: system.DWord;
end;
var
threadHandle: system.THandle;
threadInfo: ThreadNameInfo;
begin
if threadId2 < 0 then exit;
threadHandle := windows.openThread(windows.THREAD_SET_LIMITED_INFORMATION, false, system.DWord(threadId2));
if threadHandle = windows.INVALID_HANDLE_VALUE then exit;
try
if isDebuggerPresent() then begin
with threadInfo do begin
dwType := $1000;
szName := system.PAnsiChar(newDescription);
dwThreadID := system.DWord(threadId2);
dwFlags := 0;
end;
try
windows.raiseException(MS_VC_EXCEPTION, 0, sizeof(ThreadNameInfo) div sizeof(system.DWord), @threadInfo);
except
end;
end;
threadSetDescription(threadHandle, system.PWideChar(newDescription.toUTF16()));
finally
windows.closeHandle(threadHandle);
end;
end
{$ELSE}
var
threadDescription: AnsiString;
begin
if threadId2 < 0 then exit;
if newDescription.length < $10 then begin
threadDescription := newDescription;
end else begin
threadDescription := newDescription.substring($01, $10);
end;
threadSetDescription(unixtype.PThread_t(threadId2), system.PAnsiChar(threadDescription));
end
{$ENDIF};
function threadCreate(threadFunction: CodePointer; threadArgument: Pointer; stackSize: long): boolean;
{$IFDEF WINDOWS}
var
threadIdInternal: system.DWord;
begin
threadIdInternal := 0;
system.isMultiThread := true;
result := windows.createThread(nil, system.QWord(stackSize), threadFunction, threadArgument, 0, threadIdInternal) <> 0;
end
{$ELSE}
var
threadIdInternal: system.TThreadID;
begin
threadIdInternal := 0;
system.isMultiThread := true;
result := system.beginThread(TThreadFunc(threadFunction), threadArgument, threadIdInternal, system.QWord(stackSize)) <> 0;
end
{$ENDIF};
function threadIsAlive(threadId1, threadId2: long): boolean;
{$IFDEF WINDOWS}
var
threadHandle: system.THandle;
threadExitCode: system.DWord;
begin
if threadId1 < 0 then begin
result := false;
exit;
end;
threadHandle := windows.openThread(windows.THREAD_QUERY_LIMITED_INFORMATION, false, system.DWord(threadId1));
if threadHandle = windows.INVALID_HANDLE_VALUE then begin
result := false;
exit;
end;
try
threadExitCode := 0;
result := windows.getExitCodeThread(threadHandle, @threadExitCode) and (threadExitCode = windows.STILL_ACTIVE);
finally
windows.closeHandle(threadHandle);
end;
end
{$ELSE}
var
objectType: int;
threadNameLength: int;
objectName: AnsiString;
threadNameInstance: AnsiString;
objectInfo: baseunix.PDirEnt;
directoryInfo: baseunix.PDir;
threadExitCode: Pointer;
begin
if (threadId1 and threadId2) < 0 then begin
result := false;
exit;
end;
if threadId2 >= 0 then begin
threadExitCode := nil;
result := threadTryJoin(unixtype.PThread_t(threadId2), @threadExitCode) <> 0;
exit;
end;
threadNameInstance := CoLong.toString(threadId1);
threadNameLength := threadNameInstance.length;
directoryInfo := baseunix.fpOpenDir('/proc/self/task/');
if directoryInfo = nil then begin
result := false;
exit;
end;
try
repeat
objectInfo := baseunix.fpReadDir(directoryInfo^);
if objectInfo = nil then break;
objectName := AnsiString(system.PAnsiChar(@(objectInfo^.d_name)));
objectType := objectInfo^.d_type;
if
(objectName <> '.') and (objectName <> '..') and (objectType = DT_DIR) and
(objectName.length = threadNameLength) and (&Array.compfne(objectName[1], threadNameInstance[1], 0, threadNameLength) = &Array.NOT_FOUND)
then begin
result := true;
exit;
end;
until false;
finally
baseunix.fpCloseDir(directoryInfo^);
end;
result := false;
end
{$ENDIF};
function threadGetActiveCount(): int;
{$IFDEF WINDOWS}
var
processId: system.DWord;
threadInfo: ThreadEntry32;
snapshotHandle: system.THandle;
begin
processId := windows.getCurrentProcessId();
snapshotHandle := createToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
if snapshotHandle = windows.INVALID_HANDLE_VALUE then begin
result := 0;
exit;
end;
try
result := 0;
threadInfo.dwSize := sizeof(ThreadEntry32);
if thread32First(snapshotHandle, @threadInfo) then repeat
if threadInfo.th32OwnerProcessID = processId then inc(result);
until not thread32Next(snapshotHandle, @threadInfo);
finally
windows.closeHandle(snapshotHandle);
end;
end
{$ELSE}
var
objectType: int;
objectName: AnsiString;
objectInfo: baseunix.PDirEnt;
directoryInfo: baseunix.PDir;
begin
directoryInfo := baseunix.fpOpenDir('/proc/self/task/');
if directoryInfo = nil then begin
result := 0;
exit;
end;
try
result := 0;
repeat
objectInfo := baseunix.fpReadDir(directoryInfo^);
if objectInfo = nil then break;
objectName := AnsiString(system.PAnsiChar(@(objectInfo^.d_name)));
objectType := objectInfo^.d_type;
if (objectName <> '.') and (objectName <> '..') and (objectType = DT_DIR) then inc(result);
until false;
finally
baseunix.fpCloseDir(directoryInfo^);
end;
end
{$ENDIF};
function threadGetPriority(threadId2: long): int;
{$IFDEF WINDOWS}
var
threadHandle: system.THandle;
begin
if threadId2 < 0 then begin
result := Thread.UD_PRIORITY;
exit;
end;
threadHandle := windows.openThread(windows.THREAD_QUERY_LIMITED_INFORMATION, false, system.DWord(threadId2));
if threadHandle = windows.INVALID_HANDLE_VALUE then begin
result := Thread.UD_PRIORITY;
exit;
end;
try
case windows.getThreadPriority(threadHandle) of
windows.THREAD_PRIORITY_IDLE:
result := Thread.MIN_PRIORITY;
windows.THREAD_PRIORITY_LOWEST:
result := Thread.LOW_PRIORITY - 1;
windows.THREAD_PRIORITY_BELOW_NORMAL:
result := Thread.LOW_PRIORITY - 0;
windows.THREAD_PRIORITY_NORMAL:
result := Thread.NORM_PRIORITY;
windows.THREAD_PRIORITY_ABOVE_NORMAL:
result := Thread.HIGH_PRIORITY + 0;
windows.THREAD_PRIORITY_HIGHEST:
result := Thread.HIGH_PRIORITY + 1;
windows.THREAD_PRIORITY_TIME_CRITICAL:
result := Thread.MAX_PRIORITY;
else
result := Thread.UD_PRIORITY;
end;
finally
windows.closeHandle(threadHandle);
end;
end
{$ELSE}
var
policy: int;
priority: int;
begin
if threadId2 < 0 then begin
result := Thread.UD_PRIORITY;
exit;
end;
policy := 0;
priority := 0;
if threadGetSchedParam(unixtype.PThread_t(threadId2), @policy, @priority) <> 0 then begin
result := Thread.UD_PRIORITY;
exit;
end;
result := Thread.NORM_PRIORITY;
end
{$ENDIF};
function threadGetCurrentId(): long;
begin
result := {$IFDEF WINDOWS}long(windows.getCurrentThreadId()){$ELSE}doSyscall(SYSCALL_NR_GETTID){$ENDIF};
end;
{$IFNDEF WINDOWS}
function threadGetCurrentId2(): long;
begin
result := long(threadGetSelf());
end;
{$ENDIF}
function threadGetDescription(threadId2: long): AnsiString;
{$IFDEF WINDOWS}
var
threadHandle: system.THandle;
threadDescription: system.PWideChar;
begin
if threadId2 < 0 then begin
result := '';
exit;
end;
threadHandle := windows.openThread(windows.THREAD_QUERY_LIMITED_INFORMATION, false, system.DWord(threadId2));
if threadHandle = windows.INVALID_HANDLE_VALUE then begin
result := '';
exit;
end;
try
threadDescription := nil;
if windows.succeeded(threadGetDescription(threadHandle, @threadDescription)) then try
result := UnicodeString(threadDescription).toUTF8();
exit;
finally
windows.localFree(windows.HLocal((@threadDescription)^));
end;
finally
windows.closeHandle(threadHandle);
end;
result := '';
end
{$ELSE}
var
threadDescription: packed array [$00..$0f] of char;
begin
if threadId2 < 0 then begin
result := '';
exit;
end;
threadDescription[0] := #$00;
if threadGetDescription(unixtype.PThread_t(threadId2), @threadDescription, $10) = 0 then begin
result := AnsiString(system.PAnsiChar(@threadDescription));
exit;
end;
result := '';
end
{$ENDIF};
function threadEnumerateIds1(): long_Array1d;
{$IFDEF WINDOWS}
var
threadIdsLength: int;
threadIdsData: long_Array1d;
threadIdsCopy: long_Array1d;
threadInfo: ThreadEntry32;
processId: system.DWord;
snapshotHandle: system.THandle;
begin
processId := windows.getCurrentProcessId();
snapshotHandle := createToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
if snapshotHandle = windows.INVALID_HANDLE_VALUE then begin
result := nil;
exit;
end;
try
threadIdsLength := 0;
threadIdsData := &Array.newLong1d($3f);
threadInfo.dwSize := sizeof(ThreadEntry32);
if thread32First(snapshotHandle, @threadInfo) then repeat
if threadInfo.th32OwnerProcessID = processId then begin
if threadIdsLength = length(threadIdsData) then begin
threadIdsCopy := &Array.newLong1d((threadIdsLength shl 1) or 1);
&Array.copyPrimitives(threadIdsData, 0, threadIdsCopy, 0, threadIdsLength);
threadIdsData := threadIdsCopy;
end;
threadIdsData[threadIdsLength] := threadInfo.th32ThreadId;
inc(threadIdsLength);
end;
until not thread32Next(snapshotHandle, @threadInfo);
if threadIdsLength < length(threadIdsData) then begin
threadIdsCopy := &Array.newLong1d(threadIdsLength);
&Array.copyPrimitives(threadIdsData, 0, threadIdsCopy, 0, threadIdsLength);
threadIdsData := threadIdsCopy;
end;
result := threadIdsData;
finally
windows.closeHandle(snapshotHandle);
end;
end
{$ELSE}
var
objectType: int;
threadIdsLength: int;
objectName: AnsiString;
objectInfo: baseunix.PDirEnt;
directoryInfo: baseunix.PDir;
threadIdsData: long_Array1d;
threadIdsCopy: long_Array1d;
begin
directoryInfo := baseunix.fpOpenDir('/proc/self/task/');
if directoryInfo = nil then begin
result := nil;
exit;
end;
try
threadIdsLength := 0;
threadIdsData := &Array.newLong1d($3f);
repeat
objectInfo := baseunix.fpReadDir(directoryInfo^);
if objectInfo = nil then break;
objectName := AnsiString(system.PAnsiChar(@(objectInfo^.d_name)));
objectType := objectInfo^.d_type;
if (objectName <> '.') and (objectName <> '..') and (objectType = DT_DIR) then begin
if threadIdsLength = length(threadIdsData) then begin
threadIdsCopy := &Array.newLong1d((threadIdsLength shl 1) or 1);
&Array.copyPrimitives(threadIdsData, 0, threadIdsCopy, 0, threadIdsLength);
threadIdsData := threadIdsCopy;
end;
threadIdsData[threadIdsLength] := CoLong.parse(objectName);
inc(threadIdsLength);
end;
until false;
if threadIdsLength < length(threadIdsData) then begin
threadIdsCopy := &Array.newLong1d(threadIdsLength);
&Array.copyPrimitives(threadIdsData, 0, threadIdsCopy, 0, threadIdsLength);
threadIdsData := threadIdsCopy;
end;
result := threadIdsData;
finally
baseunix.fpCloseDir(directoryInfo^);
end;
end
{$ENDIF};
{%endregion}
{%region OS API — mutex}
procedure mutexCreate(aMutex: system.PRTLCriticalSection);
begin
{$IFDEF WINDOWS}
windows.initializeCriticalSection(aMutex);
{$ELSE}
system.initCriticalSection(aMutex^);
{$ENDIF}
end;
procedure mutexDestroy(aMutex: system.PRTLCriticalSection);
begin
{$IFDEF WINDOWS}
windows.deleteCriticalSection(aMutex);
{$ELSE}
system.doneCriticalSection(aMutex^);
{$ENDIF}
end;
procedure mutexLock(aMutex: system.PRTLCriticalSection);
begin
{$IFDEF WINDOWS}
windows.enterCriticalSection(aMutex);
{$ELSE}
system.enterCriticalSection(aMutex^);
{$ENDIF}
end;
procedure mutexUnlock(aMutex: system.PRTLCriticalSection);
begin
{$IFDEF WINDOWS}
windows.leaveCriticalSection(aMutex);
{$ELSE}
system.leaveCriticalSection(aMutex^);
{$ENDIF}
end;
function mutexIsHold(aMutex: system.PRTLCriticalSection): boolean;
begin
result := aMutex^.{$IFDEF WINDOWS}owningThread <> 0{$ELSE}__m_owner <> nil{$ENDIF};
end;
{%endregion}
{%region OS API — event}
function eventCreate(manualReset, initialState: boolean; const name: AnsiString): long;
begin
{$IFDEF WINDOWS}
result := long(windows.createEventW(nil, manualReset, initialState, system.PWideChar(name.toUTF16())));
{$ELSE}
result := long(system.basicEventCreate(nil, manualReset, initialState, name));
{$ENDIF}
end;
procedure eventDestroy(aEvent: long);
begin
{$IFDEF WINDOWS}
windows.closeHandle(system.THandle(aEvent));
{$ELSE}
system.basicEventDestroy(PEventState((@aEvent)^));
{$ENDIF}
end;
procedure eventSetSignalled(aEvent: long);
begin
{$IFDEF WINDOWS}
windows.setEvent(system.THandle(aEvent));
{$ELSE}
system.basicEventSetEvent(PEventState((@aEvent)^));
{$ENDIF}
end;
procedure eventWaitSignalled(aEvent: long; timeInMillis: long; timeInNanos: int);
begin
if (timeInMillis < CoLong.MAX_VALUE) and (timeInNanos >= 500000) or (timeInMillis = 0) and (timeInNanos > 0) then inc(timeInMillis);
if timeInMillis > $fffffffe then timeInMillis := $fffffffe;
if timeInMillis = 0 then timeInMillis := -1;
{$IFDEF WINDOWS}
windows.waitForSingleObject(system.THandle(aEvent), system.DWord(timeInMillis));
{$ELSE}
system.basicEventWaitFor(system.Cardinal(timeInMillis), PEventState((@aEvent)^));
{$ENDIF}
end;
{%endregion}
{%region routines — fxcontext}
procedure fxcontextLoadFrom(context: PFXContext); assembler; nostackframe;
asm
db $48
{$IFDEF WINDOWS}
fxrstor [rcx+$00]
{$ELSE}
fxrstor [rdi+$00]
{$ENDIF}
end;
procedure fxcontextSaveTo(context: PFXContext); assembler; nostackframe;
asm
db $48
{$IFDEF WINDOWS}
fxsave [rcx+$00]
{$ELSE}
fxsave [rdi+$00]
{$ENDIF}
end;
{%endregion}
{%region routines — exception}
{$IFDEF WINDOWS}
function exceptionObject(errorNumber: int; const rec: windows.TExceptionRecord): TObject;
var
exceptionInstance: TObject;
begin
case errorNumber of
1,
203: exceptionInstance := errorOutOfMemory;
204: exceptionInstance := errorInvalidPointer;
200,
205..
208,
215: exceptionInstance := ArithmeticException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'arithmetic'));
202: exceptionInstance := StackOverflowError.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, '!machine-error.stack-overflow'));
211: exceptionInstance := AbstractMethodError.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, '!error.abstract-method'));
216: exceptionInstance := NullPointerException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'null-pointer'));
219: exceptionInstance := ClassCastException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'class-cast'));
229: exceptionInstance := SafecallException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'safecall'));
else exceptionInstance := previousGetExceptionObject(errorNumber, rec);
end;
if exceptionInstance = nil then begin
exceptionInstance := NullPointerException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'null-pointer'));
end;
result := exceptionInstance;
end;
function exceptionClass(errorNumber: int): TClass;
var
exceptionType: TClass;
begin
case errorNumber of
1,
203: exceptionType := OutOfMemoryError;
204: exceptionType := InvalidPointerError;
200,
205..
208,
215: exceptionType := ArithmeticException;
202: exceptionType := StackOverflowError;
211: exceptionType := AbstractMethodError;
216: exceptionType := NullPointerException;
219: exceptionType := ClassCastException;
229: exceptionType := SafecallException;
else exceptionType := previousGetExceptionClass(errorNumber);
end;
if exceptionType = nil then begin
exceptionType := NullPointerException;
end;
result := exceptionType;
end;
{$ENDIF}
procedure exceptionHandler(errorNumber: int; address: CodePointer; frame: Pointer);
var
exceptionInstance: TObject;
begin
case errorNumber of
1,
203: exceptionInstance := errorOutOfMemory;
204: exceptionInstance := errorInvalidPointer;
200,
205..
208,
215: exceptionInstance := ArithmeticException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'arithmetic'));
202: exceptionInstance := StackOverflowError.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, '!machine-error.stack-overflow'));
211: exceptionInstance := AbstractMethodError.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, '!error.abstract-method'));
216: exceptionInstance := NullPointerException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'null-pointer'));
219: exceptionInstance := ClassCastException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'class-cast'));
229: exceptionInstance := SafecallException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'safecall'));
else
exceptionInstance := nil;
previousExceptionHandler(errorNumber, address, frame);
end;
if exceptionInstance = nil then begin
exceptionInstance := NullPointerException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'null-pointer'));
end;
raise exceptionInstance at address, frame;
end;
procedure exceptionInitialize();
begin
{$IFDEF WINDOWS}
previousGetExceptionObject := FunctionGetExceptionObject(exceptObjProc);
previousGetExceptionClass := FunctionGetExceptionClass(exceptClsProc);
{$ENDIF}
previousExceptionHandler := errorProc;
errorInvalidPointer := InvalidPointerError.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, '!error.invalid-pointer'));
errorInvalidPointer.freeDisallow();
errorOutOfMemory := OutOfMemoryError.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, '!machine-error.out-of-memory'));
errorOutOfMemory.freeDisallow();
{$IFDEF WINDOWS}
exceptObjProc := @exceptionObject;
exceptClsProc := @exceptionClass;
{$ENDIF}
errorProc := @exceptionHandler;
end;
procedure exceptionFinalize();
begin
{$IFDEF WINDOWS}
exceptObjProc := previousGetExceptionObject;
exceptClsProc := previousGetExceptionClass;
{$ENDIF}
errorProc := previousExceptionHandler;
errorInvalidPointer.freeAllow();
errorInvalidPointer.free();
errorOutOfMemory.freeAllow();
errorOutOfMemory.free();
end;
{%endregion}
{%region routines — thread}
procedure threadInitialize();
begin
threadLength := 0;
threadEntries := ThreadEntry_Array1d(&Array.newTObject1d($3f));
threadOperation := Mutex.create();
end;
procedure threadFinalize();
var
idx: int;
currEntry: ThreadEntry;
nextEntry: ThreadEntry;
begin
threadOperation.beginSynchronized();
try
for idx := length(threadEntries) - 1 downto 0 do begin
currEntry := threadEntries[idx];
threadEntries[idx] := nil;
while currEntry <> nil do begin
nextEntry := currEntry.next;
currEntry.free();
currEntry := nextEntry;
end;
end;
threadEntries := nil;
threadLength := 0;
finally
threadOperation.endSynchronized();
end;
threadOperation.free();
threadOperation := nil;
end;
procedure threadClean();
var
idx: int;
prevEntry: ThreadEntry;
currEntry: ThreadEntry;
nextEntry: ThreadEntry;
begin
threadOperation.beginSynchronized();
try
for idx := length(threadEntries) - 1 downto 0 do begin
prevEntry := nil;
currEntry := threadEntries[idx];
while currEntry <> nil do begin
if not threadIsAlive(currEntry.threadId1, currEntry.threadId2) then begin
nextEntry := currEntry.next;
currEntry.free();
if prevEntry = nil then begin
threadEntries[idx] := nextEntry;
end else begin
prevEntry.next := nextEntry;
end;
dec(threadLength);
currEntry := nextEntry;
continue;
end;
prevEntry := currEntry;
currEntry := currEntry.next;
end;
end;
finally
threadOperation.endSynchronized();
end;
end;
procedure threadRehash();
var
oldCap: int;
oldIdx: int;
newCap: int;
newIdx: int;
oldEntry: ThreadEntry;
newEntry: ThreadEntry;
oldTable: ThreadEntry_Array1d;
newTable: ThreadEntry_Array1d;
begin
oldTable := threadEntries;
oldCap := length(oldTable);
newCap := (oldCap shl 1) or 1;
if newCap < 0 then newCap := CoInt.MAX_VALUE;
newTable := ThreadEntry_Array1d(&Array.newTObject1d(newCap));
for oldIdx := oldCap - 1 downto 0 do begin
oldEntry := oldTable[oldIdx];
while oldEntry <> nil do begin
newIdx := int((oldEntry.threadId1 and CoLong.MAX_VALUE) mod newCap);
newEntry := oldEntry;
oldEntry := oldEntry.next;
newEntry.next := newTable[newIdx];
newTable[newIdx] := newEntry;
end;
end;
threadEntries := newTable;
end;
procedure threadAdd(threadInstance: Thread);
var
len: int;
cap: int;
idx: int;
threadId1: long;
currEntry: ThreadEntry;
begin
threadId1 := threadInstance.fldThreadId1;
threadOperation.beginSynchronized();
try
cap := length(threadEntries);
idx := int((threadId1 and CoLong.MAX_VALUE) mod cap);
currEntry := threadEntries[idx];
while currEntry <> nil do begin
if currEntry.threadId1 = threadId1 then begin
currEntry.threadOld := currEntry.threadRef;
currEntry.threadRef := threadInstance;
exit;
end;
currEntry := currEntry.next;
end;
len := threadLength + 1;
if len > ((cap shl 1) or 1) then begin
threadRehash();
idx := int((threadId1 and CoLong.MAX_VALUE) mod length(threadEntries));
end;
threadEntries[idx] := ThreadEntry.create(threadId1, threadInstance.fldThreadId2, threadInstance, threadEntries[idx]);
threadLength := len;
finally
threadOperation.endSynchronized();
end;
end;
procedure threadDecrementEnum(threadInstance: Thread);
begin
threadOperation.beginSynchronized();
try
dec(threadInstance.fldEnumerated);
finally
threadOperation.endSynchronized();
end;
end;
procedure threadRemove(threadInstance: Thread; needDecrementEnum: boolean = false);
var
idx: int;
threadId1: long;
prevEntry: ThreadEntry;
currEntry: ThreadEntry;
nextEntry: ThreadEntry;
begin
threadId1 := threadInstance.fldThreadId1;
threadOperation.beginSynchronized();
try
if needDecrementEnum then dec(threadInstance.fldEnumerated);
idx := int((threadId1 and CoLong.MAX_VALUE) mod length(threadEntries));
prevEntry := nil;
currEntry := threadEntries[idx];
while currEntry <> nil do begin
if currEntry.threadId1 = threadId1 then begin
nextEntry := currEntry.next;
currEntry.free();
if prevEntry = nil then begin
threadEntries[idx] := nextEntry;
end else begin
prevEntry.next := nextEntry;
end;
dec(threadLength);
exit;
end;
prevEntry := currEntry;
currEntry := currEntry.next;
end;
threadInstance.freeIfNecessary();
finally
threadOperation.endSynchronized();
end;
end;
function threadGetEvent(threadId1: long): long;
var
idx: int;
currEntry: ThreadEntry;
begin
threadOperation.beginSynchronized();
try
idx := int((threadId1 and CoLong.MAX_VALUE) mod length(threadEntries));
currEntry := threadEntries[idx];
while currEntry <> nil do begin
if currEntry.threadId1 = threadId1 then begin
result := currEntry.event;
exit;
end;
currEntry := currEntry.next;
end;
finally
threadOperation.endSynchronized();
end;
result := 0;
end;
function threadGet(threadId1: long; needIncrementEnum: boolean = false): Thread;
var
len: int;
cap: int;
idx: int;
currEntry: ThreadEntry;
threadInstance: Thread;
begin
threadOperation.beginSynchronized();
try
cap := length(threadEntries);
idx := int((threadId1 and CoLong.MAX_VALUE) mod cap);
currEntry := threadEntries[idx];
while currEntry <> nil do begin
if currEntry.threadId1 = threadId1 then begin
threadInstance := currEntry.threadRef;
if needIncrementEnum then inc(threadInstance.fldEnumerated);
result := threadInstance;
exit;
end;
currEntry := currEntry.next;
end;
len := threadLength + 1;
if len > ((cap shl 1) or 1) then begin
threadRehash();
idx := int((threadId1 and CoLong.MAX_VALUE) mod length(threadEntries));
end;
threadInstance := Thread.create(threadId1, -1);
if needIncrementEnum then inc(threadInstance.fldEnumerated);
threadEntries[idx] := ThreadEntry.create(threadId1, -1, threadInstance, threadEntries[idx]);
threadLength := len;
result := threadInstance;
finally
threadOperation.endSynchronized();
end;
end;
function threadFunction(threadInstance: Thread): {$IFDEF WINDOWS}int; stdcall{$ELSE}long; cdecl{$ENDIF};
var
threadId1: long;
threadId2: long;
threadTarget: Runnable;
begin
try
fxcontextLoadFrom(@fpusseDefaultContext);
threadId1 := threadGetCurrentId();
threadId2 := {$IFDEF WINDOWS}threadId1{$ELSE}threadGetCurrentId2(){$ENDIF};
threadInstance.fldThreadId1 := threadId1;
threadInstance.fldThreadId2 := threadId2;
threadAdd(threadInstance);
threadInstance.fldCreated := false;
try
try
threadSetPriority(threadId2, threadInstance.fldPriority);
threadSetDescription(threadId2, threadInstance.fldDescription);
threadTarget := threadInstance.fldTarget;
if threadTarget = nil then threadTarget := threadInstance;
threadTarget.run();
finally
threadInstance.notifyJoined();
end;
except
on exception: Throwable do begin
exception.printStackTrace();
end;
on exception: TObject do begin
if isConsole then begin
writeln(system.errOutput, exception.toString(){$IFDEF WINDOWS}.toUTF16(){$ENDIF});
end;
end;
else begin
if isConsole then begin
writeln(system.errOutput, AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, '!error.unknown'){$IFDEF WINDOWS}.toUTF16(){$ENDIF});
end;
end;
end;
threadRemove(threadInstance);
threadClean();
except
if isConsole then begin
writeln(system.errOutput, AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, '!error.thread-registration'){$IFDEF WINDOWS}.toUTF16(){$ENDIF});
end;
end;
result := 0;
end;
{%endregion}
{%region routines — interface}
procedure interfaceInitialize();
begin
registeredInterfacesLength := 0;
registeredInterfacesEntries := InterfaceEntry_Array1d(&Array.newTObject1d($3f));
end;
procedure interfaceFinalize();
var
idx: int;
currEntry: InterfaceEntry;
nextEntry: InterfaceEntry;
begin
for idx := length(registeredInterfacesEntries) - 1 downto 0 do begin
currEntry := registeredInterfacesEntries[idx];
registeredInterfacesEntries[idx] := nil;
while currEntry <> nil do begin
nextEntry := currEntry.next;
currEntry.free();
currEntry := nextEntry;
end;
end;
registeredInterfacesEntries := nil;
registeredInterfacesLength := 0;
end;
{%endregion}
{%region routines — interlocked}
function interlockedIncrementInt(field: Pint): int; assembler; nostackframe;
asm
mov eax, $00000001
{$IFDEF WINDOWS}
lock xadd dword [rcx+$00], eax
{$ELSE}
lock xadd dword [rdi+$00], eax
{$ENDIF}
inc eax
end;
function interlockedDecrementInt(field: Pint): int; assembler; nostackframe;
asm
mov eax, $ffffffff
{$IFDEF WINDOWS}
lock xadd dword [rcx+$00], eax
{$ELSE}
lock xadd dword [rdi+$00], eax
{$ENDIF}
dec eax
end;
{%endregion}
{%region routines — newInt2}
function newInt2(value0, value1: int): int2;
begin
result[0] := value0;
result[1] := value1;
end;
function newInt2Array1d(length: int): int2_Array1d;
begin
result := nil;
setLength(result, length);
end;
{%endregion}
{%region routines — GUID}
function guidTryParse(const str: ShortString; out guid: system.TGuid): boolean;
var
success: boolean;
idx: int;
procedure skipChar(chr: char);
begin
if str[idx] <> chr then begin
success := false;
end;
inc(idx);
end;
function readChar(): int;
var
chr: char;
begin
chr := str[idx];
inc(idx);
case chr of
'0'..'9':
result := int(chr) - int('0');
'a'..'f':
result := int(chr) - (int('a') - $0a);
'A'..'F':
result := int(chr) - (int('A') - $0a);
else
success := false;
result := 0;
end;
end;
begin
if length(str) <> 38 then begin
guid.data1 := 0;
guid.data2 := 0;
guid.data3 := 0;
long(guid.data4) := 0;
result := false;
exit;
end;
success := true;
idx := 1;
skipChar('{');
guid.data1 := system.DWord(
(readChar() shl $1c) or (readChar() shl $18) or (readChar() shl $14) or (readChar() shl $10) or
(readChar() shl $0c) or (readChar() shl $08) or (readChar() shl $04) or readChar()
);
skipChar('-');
guid.data2 := system.Word((readChar() shl $0c) or (readChar() shl $08) or (readChar() shl $04) or readChar());
skipChar('-');
guid.data3 := system.Word((readChar() shl $0c) or (readChar() shl $08) or (readChar() shl $04) or readChar());
skipChar('-');
guid.data4[0] := system.Byte((readChar() shl 4) or readChar());
guid.data4[1] := system.Byte((readChar() shl 4) or readChar());
skipChar('-');
guid.data4[2] := system.Byte((readChar() shl 4) or readChar());
guid.data4[3] := system.Byte((readChar() shl 4) or readChar());
guid.data4[4] := system.Byte((readChar() shl 4) or readChar());
guid.data4[5] := system.Byte((readChar() shl 4) or readChar());
guid.data4[6] := system.Byte((readChar() shl 4) or readChar());
guid.data4[7] := system.Byte((readChar() shl 4) or readChar());
skipChar('}');
result := success;
end;
function guidToString(const guid: system.TGuid): ShortString;
const
HEX: array [$00..$0f] of char = ( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' );
var
cnt: int;
idx: int;
val: long;
str: ShortString;
procedure writeChar();
begin
str[idx] := HEX[int((val shr (cnt shl 2)) and $0f)];
inc(idx);
end;
begin
str := '{00000000-0000-0000-0000-000000000000}';
val := guid.data1;
idx := 2;
for cnt := $07 downto $00 do writeChar();
val := guid.data2;
inc(idx);
for cnt := $03 downto $00 do writeChar();
val := guid.data3;
inc(idx);
for cnt := $03 downto $00 do writeChar();
val := CoLong.byteSwap(long(guid.data4));
inc(idx);
for cnt := $0f downto $0c do writeChar();
{ val := val; }
inc(idx);
for cnt := $0b downto $00 do writeChar();
result := str;
end;
{%endregion}
{%region routines — resourcestring}
function resourcestringOverride(const name, value: AnsiString; hash: int; arg: Pointer): AnsiString;
var
idx: int;
pos: int;
str: AnsiString;
ovr: AnsiString;
begin
str := name.toLowerCase();
for idx := 0 to system.length(resourcestringOverrides) - 1 do begin
ovr := resourcestringOverrides[idx];
pos := ovr.indexOf('=');
if (pos > 0) and (str = ovr.substring(1, pos).toLowerCase()) then begin
result := ovr.substring(1 + pos);
exit;
end;
end;
result := value;
end;
{%endregion}
{%region &Object}
constructor &Object.create();
begin
inherited create();
end;
destructor &Object.destroy;
begin
inherited destroy;
end;
procedure &Object.afterConstruction();
begin
end;
procedure &Object.beforeDestruction();
begin
end;
function &Object.equals(anot: TObject): boolean;
begin
result := anot = self;
end;
function &Object.getHashCode(): long;
begin
result := long(self);
end;
function &Object.toString(): AnsiString;
begin
result := getClass().getCanonicalName() + '@' + CoLong.toHexString(getHashCode());
end;
function &Object.queryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid: system.TGuid; out obj): int; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
begin
if &Array.compfne(IObjectInstance, iid, 3, 2) = &Array.NOT_FOUND then begin
TObject(obj) := self;
result := system.S_OK;
exit;
end;
if getInterface(guidToString(iid), obj) then begin
result := system.S_OK;
exit;
end;
result := system.E_NOINTERFACE;
end;
function &Object._addref(): int; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
begin
result := -1;
end;
function &Object._release(): int; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
begin
result := -1;
end;
{%endregion}
{%region RefCountObject}
class function RefCountObject.newInstance(): TObject;
begin
result := inherited newInstance();
if result <> nil then begin
RefCountObject(result).fldRefCount := 1;
end;
end;
procedure RefCountObject.afterConstruction(); assembler; nostackframe;
asm
{$IFDEF WINDOWS}
lock dec dword [rcx+offset fldRefCount]
{$ELSE}
lock dec dword [rdi+offset fldRefCount]
{$ENDIF}
end;
procedure RefCountObject.beforeDestruction();
begin
if fldRefCount <> 0 then begin
raise InvalidPointerError.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, '!error.invalid-ref-count'));
end;
end;
function RefCountObject._addref(): int; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
begin
result := interlockedIncrementInt(@fldRefCount);
end;
function RefCountObject._release(): int; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
begin
result := interlockedDecrementInt(@fldRefCount);
if result = 0 then destroy;
end;
{%endregion}
{%region DynamicObject}
constructor DynamicObject.create();
begin
inherited create();
end;
{%endregion}
{%region CoBoolean}
constructor CoBoolean.create(const value: boolean);
begin
inherited create();
if value then begin
fldValue := -1;
exit;
end;
fldValue := 0;
end;
procedure CoBoolean.writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 1);
dst[offset] := byte(-fldValue);
end;
procedure CoBoolean.writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 1);
dst[offset] := byte(-fldValue);
end;
function CoBoolean.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is CoBoolean) and (CoBoolean(anot).fldValue = fldValue);
end;
function CoBoolean.getHashCode(): long;
begin
if fldValue <> 0 then begin
result := 1231;
exit;
end;
result := 1237;
end;
function CoBoolean.toString(): AnsiString;
begin
if fldValue <> 0 then begin
result := 'true';
exit;
end;
result := 'false';
end;
function CoBoolean.getSize(): int;
begin
result := sizeof(fldValue);
end;
function CoBoolean.getType(): int;
begin
result := Lang.TYPE_BOOLEAN;
end;
function CoBoolean.isNaN(): boolean;
begin
result := false;
end;
function CoBoolean.isInfinite(): boolean;
begin
result := false;
end;
function CoBoolean.asBoolean(): boolean;
begin
result := fldValue <> 0;
end;
function CoBoolean.asInt(): int;
begin
result := fldValue;
end;
function CoBoolean.asLong(): long;
begin
result := fldValue;
end;
function CoBoolean.asFloat(): float;
begin
result := CoInt.toFloat(fldValue);
end;
function CoBoolean.asDouble(): double;
begin
result := CoInt.toDouble(fldValue);
end;
function CoBoolean.asReal(): real;
begin
result := CoInt.toReal(fldValue);
end;
function CoBoolean.asAnsiString(): AnsiString;
begin
if fldValue <> 0 then begin
result := 'true';
exit;
end;
result := 'false';
end;
function CoBoolean.asUnicodeString(): UnicodeString;
begin
if fldValue <> 0 then begin
result := 'true';
exit;
end;
result := 'false';
end;
function CoBoolean.asObject(): TObject;
begin
result := self;
end;
function CoBoolean.asSimple(): ISimple;
begin
result := self;
end;
{%endregion}
{%region CoChar}
class function CoChar.isDigit(character: char): boolean;
begin
result := (character >= '0') and (character <= '9');
end;
class function CoChar.isLowerCase(character: char): boolean;
begin
result := (character >= 'a') and (character <= 'z');
end;
class function CoChar.isUpperCase(character: char): boolean;
begin
result := (character >= 'A') and (character <= 'Z');
end;
class function CoChar.toLowerCase(character: char): char;
begin
if (character >= 'A') and (character <= 'Z') then begin
result := char(int(character) + $20);
exit;
end;
result := character;
end;
class function CoChar.toUpperCase(character: char): char;
begin
if (character >= 'a') and (character <= 'z') then begin
result := char(int(character) - $20);
exit;
end;
result := character;
end;
class function CoChar.toChar(digit: int): char;
begin
if (digit >= $00) and (digit < $0a) then begin
result := char(digit + int('0'));
exit;
end;
if (digit >= $0a) and (digit < CoChar.MAX_RADIX) then begin
result := char(digit + (int('a') - $0a));
exit;
end;
result := '?';
end;
class function CoChar.toDigit(character: char; radix: int): int;
var
value: int;
begin
value := -1;
if (radix >= CoChar.MIN_RADIX) and (radix <= CoChar.MAX_RADIX) then begin
if (character >= '0') and (character <= '9') then begin
value := int(character) - int('0');
end else
if (character >= 'A') and (character <= 'Z') or (character >= 'a') and (character <= 'z') then begin
value := (int(character) and $1f) + 9;
end;
end;
if value >= radix then value := -1;
result := value;
end;
constructor CoChar.create(const value: char);
begin
inherited create();
fldValue := value;
end;
procedure CoChar.writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 1);
dst[offset] := byte(fldValue);
end;
procedure CoChar.writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 1);
dst[offset] := byte(fldValue);
end;
function CoChar.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is CoChar) and (CoChar(anot).fldValue = fldValue);
end;
function CoChar.getHashCode(): long;
begin
result := long(fldValue);
end;
function CoChar.toString(): AnsiString;
begin
result := fldValue;
end;
function CoChar.getSize(): int;
begin
result := sizeof(fldValue);
end;
function CoChar.getType(): int;
begin
result := Lang.TYPE_CHAR;
end;
function CoChar.isNaN(): boolean;
begin
result := false;
end;
function CoChar.isInfinite(): boolean;
begin
result := false;
end;
function CoChar.asBoolean(): boolean;
begin
result := fldValue <> #$00;
end;
function CoChar.asInt(): int;
begin
result := int(fldValue);
end;
function CoChar.asLong(): long;
begin
result := long(fldValue);
end;
function CoChar.asFloat(): float;
begin
result := CoInt.toFloat(int(fldValue));
end;
function CoChar.asDouble(): double;
begin
result := CoInt.toDouble(int(fldValue));
end;
function CoChar.asReal(): real;
begin
result := CoInt.toReal(int(fldValue));
end;
function CoChar.asAnsiString(): AnsiString;
begin
result := fldValue;
end;
function CoChar.asUnicodeString(): UnicodeString;
begin
result := uchar(fldValue);
end;
function CoChar.asObject(): TObject;
begin
result := self;
end;
function CoChar.asSimple(): ISimple;
begin
result := self;
end;
{%endregion}
{%region CoUChar}
class function CoUChar.isDigit(character: uchar): boolean;
begin
result := BasicLatin.isDigit(character) or Locale.getInstance().isDigit(character);
end;
class function CoUChar.isLowerCase(character: uchar): boolean;
begin
result := BasicLatin.isLowerCase(character) or Locale.getInstance().isLowerCase(character);
end;
class function CoUChar.isUpperCase(character: uchar): boolean;
begin
result := BasicLatin.isUpperCase(character) or Locale.getInstance().isUpperCase(character);
end;
class function CoUChar.toLowerCase(character: uchar): uchar;
begin
if character < #$0100 then begin
result := BasicLatin.toLowerCase(character);
exit;
end;
result := Locale.getInstance().toLowerCase(character);
end;
class function CoUChar.toUpperCase(character: uchar): uchar;
begin
if character < #$0100 then begin
result := BasicLatin.toUpperCase(character);
exit;
end;
result := Locale.getInstance().toUpperCase(character);
end;
class function CoUChar.toChar(digit: int): uchar;
begin
if (digit >= $00) and (digit < $0a) then begin
result := uchar(digit + int('0'));
exit;
end;
if (digit >= $0a) and (digit < CoUChar.MAX_RADIX) then begin
result := uchar(digit + (int('a') - $0a));
exit;
end;
result := '?';
end;
class function CoUChar.toDigit(character: uchar; radix: int): int;
var
value: int;
begin
value := -1;
if (radix >= CoUChar.MIN_RADIX) and (radix <= CoUChar.MAX_RADIX) then begin
if (character >= '0') and (character <= '9') then begin
value := int(character) - int('0');
end else
if (character >= 'A') and (character <= 'Z') or (character >= 'a') and (character <= 'z') then begin
value := (int(character) and $1f) + 9;
end;
end;
if value >= radix then value := -1;
result := value;
end;
constructor CoUChar.create(const value: uchar);
begin
inherited create();
fldValue := value;
end;
procedure CoUChar.writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 2);
short((@(dst[offset]))^) := CoShort.byteSwap(short(fldValue));
end;
procedure CoUChar.writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 2);
uchar((@(dst[offset]))^) := fldValue;
end;
function CoUChar.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is CoUChar) and (CoUChar(anot).fldValue = fldValue);
end;
function CoUChar.getHashCode(): long;
begin
result := long(fldValue);
end;
function CoUChar.toString(): AnsiString;
begin
result := UnicodeString(fldValue).toUTF8();
end;
function CoUChar.getSize(): int;
begin
result := sizeof(fldValue);
end;
function CoUChar.getType(): int;
begin
result := Lang.TYPE_UCHAR;
end;
function CoUChar.isNaN(): boolean;
begin
result := false;
end;
function CoUChar.isInfinite(): boolean;
begin
result := false;
end;
function CoUChar.asBoolean(): boolean;
begin
result := fldValue <> #$0000;
end;
function CoUChar.asInt(): int;
begin
result := int(fldValue);
end;
function CoUChar.asLong(): long;
begin
result := long(fldValue);
end;
function CoUChar.asFloat(): float;
begin
result := CoInt.toFloat(int(fldValue));
end;
function CoUChar.asDouble(): double;
begin
result := CoInt.toDouble(int(fldValue));
end;
function CoUChar.asReal(): real;
begin
result := CoInt.toReal(int(fldValue));
end;
function CoUChar.asAnsiString(): AnsiString;
begin
result := UnicodeString(fldValue).toUTF8();
end;
function CoUChar.asUnicodeString(): UnicodeString;
begin
result := fldValue;
end;
function CoUChar.asObject(): TObject;
begin
result := self;
end;
function CoUChar.asSimple(): ISimple;
begin
result := self;
end;
{%endregion}
{%region CoByte}
class function CoByte.parse(const str: AnsiString; radix: int): byte;
var
value: int;
begin
value := CoInt.parse(str, radix);
if (value < MIN_VALUE) or (value > MAX_VALUE) then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
result := byte(value);
end;
class function CoByte.parseUnsigned(const str: AnsiString; radix: int): byte;
var
value: int;
begin
value := CoInt.parseUnsigned(str, radix);
if (value and $ffffff00) <> 0 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
result := byte(value);
end;
constructor CoByte.create(const value: byte);
begin
inherited create();
fldValue := value;
end;
procedure CoByte.writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 1);
dst[offset] := fldValue;
end;
procedure CoByte.writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 1);
dst[offset] := fldValue;
end;
function CoByte.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is CoByte) and (CoByte(anot).fldValue = fldValue);
end;
function CoByte.getHashCode(): long;
begin
result := fldValue;
end;
function CoByte.toString(): AnsiString;
begin
result := CoInt.toString(fldValue);
end;
function CoByte.getSize(): int;
begin
result := sizeof(fldValue);
end;
function CoByte.getType(): int;
begin
result := Lang.TYPE_BYTE;
end;
function CoByte.isNaN(): boolean;
begin
result := false;
end;
function CoByte.isInfinite(): boolean;
begin
result := false;
end;
function CoByte.asBoolean(): boolean;
begin
result := fldValue <> 0;
end;
function CoByte.asInt(): int;
begin
result := fldValue;
end;
function CoByte.asLong(): long;
begin
result := fldValue;
end;
function CoByte.asFloat(): float;
begin
result := CoInt.toFloat(fldValue);
end;
function CoByte.asDouble(): double;
begin
result := CoInt.toDouble(fldValue);
end;
function CoByte.asReal(): real;
begin
result := CoInt.toReal(fldValue);
end;
function CoByte.asAnsiString(): AnsiString;
begin
result := CoInt.toString(fldValue);
end;
function CoByte.asUnicodeString(): UnicodeString;
begin
result := CoInt.toString(fldValue).toUTF16();
end;
function CoByte.asObject(): TObject;
begin
result := self;
end;
function CoByte.asSimple(): ISimple;
begin
result := self;
end;
{%endregion}
{%region CoShort}
class function CoShort.parse(const str: AnsiString; radix: int): short;
var
value: int;
begin
value := CoInt.parse(str, radix);
if (value < MIN_VALUE) or (value > MAX_VALUE) then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
result := short(value);
end;
class function CoShort.parseUnsigned(const str: AnsiString; radix: int): short;
var
value: int;
begin
value := CoInt.parseUnsigned(str, radix);
if (value and $ffff0000) <> 0 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
result := short(value);
end;
class function CoShort.byteSwap(value: short): short; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
mov ax, cx
{$ELSE}
mov ax, di
{$ENDIF}
xchg al, ah
movsx eax, ax
end;
constructor CoShort.create(const value: short);
begin
inherited create();
fldValue := value;
end;
procedure CoShort.writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 2);
short((@(dst[offset]))^) := byteSwap(fldValue);
end;
procedure CoShort.writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 2);
short((@(dst[offset]))^) := fldValue;
end;
function CoShort.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is CoShort) and (CoShort(anot).fldValue = fldValue);
end;
function CoShort.getHashCode(): long;
begin
result := fldValue;
end;
function CoShort.toString(): AnsiString;
begin
result := CoInt.toString(fldValue);
end;
function CoShort.getSize(): int;
begin
result := sizeof(fldValue);
end;
function CoShort.getType(): int;
begin
result := Lang.TYPE_SHORT;
end;
function CoShort.isNaN(): boolean;
begin
result := false;
end;
function CoShort.isInfinite(): boolean;
begin
result := false;
end;
function CoShort.asBoolean(): boolean;
begin
result := fldValue <> 0;
end;
function CoShort.asInt(): int;
begin
result := fldValue;
end;
function CoShort.asLong(): long;
begin
result := fldValue;
end;
function CoShort.asFloat(): float;
begin
result := CoInt.toFloat(fldValue);
end;
function CoShort.asDouble(): double;
begin
result := CoInt.toDouble(fldValue);
end;
function CoShort.asReal(): real;
begin
result := CoInt.toReal(fldValue);
end;
function CoShort.asAnsiString(): AnsiString;
begin
result := CoInt.toString(fldValue);
end;
function CoShort.asUnicodeString(): UnicodeString;
begin
result := CoInt.toString(fldValue).toUTF16();
end;
function CoShort.asObject(): TObject;
begin
result := self;
end;
function CoShort.asSimple(): ISimple;
begin
result := self;
end;
{%endregion}
{%region CoInt}
class function CoInt.toUnsignedStringByShift(uvalue: int; shift: int): AnsiString;
var
idx: int;
len: int;
msk: int;
buf: char_Array1d;
begin
idx := 32;
len := idx;
msk := (1 shl shift) - 1;
buf := &Array.newChar1d(len);
repeat
dec(idx);
buf[idx] := CoChar.toChar(uvalue and msk);
uvalue := uvalue shr shift;
until uvalue = 0;
result := AnsiString.create(buf, idx, len - idx);
end;
class function CoInt.parse(const str: AnsiString; radix: int): int;
var
negative: boolean;
idx: int;
len: int;
limit: int;
digit: int;
mulmin: int;
parsed: int;
begin
len := str.length;
if len <= 0 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
if (radix < CoChar.MIN_RADIX) or (radix > CoChar.MAX_RADIX) then begin
raise NumberFormatException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format.radix'), [ CoInt.create(radix) ]));
end;
parsed := 0;
idx := 0;
if str[1] = '-' then begin
inc(idx);
negative := true;
limit := -$80000000;
end else begin
negative := false;
limit := -$7fffffff;
end;
if idx < len then begin
digit := CoChar.toDigit(str[idx + 1], radix);
if digit < 0 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
parsed := -digit;
inc(idx);
end;
mulmin := limit div radix;
while idx < len do begin
digit := CoChar.toDigit(str[idx + 1], radix);
if (digit < 0) or (parsed < mulmin) then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
parsed := parsed * radix;
if parsed < limit + digit then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
parsed := parsed - digit;
inc(idx);
end;
if negative then begin
if idx < 2 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
result := parsed;
exit;
end;
result := -parsed;
end;
class function CoInt.parseUnsigned(const str: AnsiString; radix: int): int;
var
idx: int;
len: int;
digit: int;
mulmin: int;
parsed: int;
begin
len := str.length;
if len <= 0 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
if (radix < CoChar.MIN_RADIX) or (radix > CoChar.MAX_RADIX) then begin
raise NumberFormatException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format.radix'), [ CoInt.create(radix) ]));
end;
parsed := CoChar.toDigit(str[1], radix);
if parsed < 0 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
mulmin := divUnsigned(int($ffffffff), radix);
for idx := 1 to len - 1 do begin
digit := CoChar.toDigit(str[idx + 1], radix);
if (digit < 0) or (cmpUnsigned(parsed, mulmin) > 0) then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
parsed := parsed * radix;
if cmpUnsigned(parsed, $ffffffff - digit) > 0 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
parsed := parsed + digit;
end;
result := parsed;
end;
class function CoInt.byteSwap(value: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
mov eax, ecx
{$ELSE}
mov eax, edi
{$ENDIF}
bswap eax
end;
class function CoInt.bound(value, minimum, maximum: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cmp ecx, edx
jge @00
mov eax, edx
ret
@00: cmp ecx, r8d
jle @01
mov eax, r8d
ret
@01: mov eax, ecx
{$ELSE}
cmp edi, esi
jge @00
mov eax, esi
ret
@00: cmp edi, edx
jle @01
mov eax, edx
ret
@01: mov eax, edi
{$ENDIF}
end;
class function CoInt.max(value1, value2: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cmp ecx, edx
jl @00
mov eax, ecx
ret
@00: mov eax, edx
{$ELSE}
cmp edi, esi
jl @00
mov eax, edi
ret
@00: mov eax, esi
{$ENDIF}
end;
class function CoInt.min(value1, value2: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cmp ecx, edx
jg @00
mov eax, ecx
ret
@00: mov eax, edx
{$ELSE}
cmp edi, esi
jg @00
mov eax, edi
ret
@00: mov eax, esi
{$ENDIF}
end;
class function CoInt.sar(value: int; bits: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
mov eax, ecx
mov ecx, edx
{$ELSE}
mov eax, edi
mov ecx, esi
{$ENDIF}
sar eax, cl
end;
class function CoInt.rol(value: int; bits: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
mov eax, ecx
mov ecx, edx
{$ELSE}
mov eax, edi
mov ecx, esi
{$ENDIF}
rol eax, cl
end;
class function CoInt.boundUnsigned(uvalue, uminimum, umaximum: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cmp ecx, edx
jae @00
mov eax, edx
ret
@00: cmp ecx, r8d
jbe @01
mov eax, r8d
ret
@01: mov eax, ecx
{$ELSE}
cmp edi, esi
jae @00
mov eax, esi
ret
@00: cmp edi, edx
jbe @01
mov eax, edx
ret
@01: mov eax, edi
{$ENDIF}
end;
class function CoInt.cmpUnsigned(uvalue1, uvalue2: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cmp ecx, edx
{$ELSE}
cmp edi, esi
{$ENDIF}
jb @lt
je @eq
@gt: mov eax, $00000001
ret
@lt: mov eax, $ffffffff
ret
@eq: xor eax, eax
end;
class function CoInt.divUnsigned(uvalue1, uvalue2: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
mov eax, ecx
mov ecx, edx
{$ELSE}
mov eax, edi
mov ecx, esi
{$ENDIF}
xor edx, edx
div ecx
end;
class function CoInt.remUnsigned(uvalue1, uvalue2: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
mov eax, ecx
mov ecx, edx
{$ELSE}
mov eax, edi
mov ecx, esi
{$ENDIF}
xor edx, edx
div ecx
mov eax, edx
end;
class function CoInt.maxUnsigned(uvalue1, uvalue2: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cmp ecx, edx
jb @00
mov eax, ecx
ret
@00: mov eax, edx
{$ELSE}
cmp edi, esi
jb @00
mov eax, edi
ret
@00: mov eax, esi
{$ENDIF}
end;
class function CoInt.minUnsigned(uvalue1, uvalue2: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cmp ecx, edx
ja @00
mov eax, ecx
ret
@00: mov eax, edx
{$ELSE}
cmp edi, esi
ja @00
mov eax, edi
ret
@00: mov eax, esi
{$ENDIF}
end;
class function CoInt.toFloatBits(value: int): float; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
movd xmm0, ecx
{$ELSE}
movd xmm0, edi
{$ENDIF}
end;
class function CoInt.toFloat(value: int): float; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cvtsi2ss xmm0, ecx
{$ELSE}
cvtsi2ss xmm0, edi
{$ENDIF}
end;
class function CoInt.toUnsignedFloat(uvalue: int): float; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
sub ecx, $80000000
cvtsi2ss xmm0, ecx
{$ELSE}
sub edi, $80000000
cvtsi2ss xmm0, edi
{$ENDIF}
addss xmm0, [rip+floats-@00+$00]
@00:
end;
class function CoInt.toDouble(value: int): double; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cvtsi2sd xmm0, ecx
{$ELSE}
cvtsi2sd xmm0, edi
{$ENDIF}
end;
class function CoInt.toUnsignedDouble(uvalue: int): double; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
sub ecx, $80000000
cvtsi2sd xmm0, ecx
{$ELSE}
sub edi, $80000000
cvtsi2sd xmm0, edi
{$ENDIF}
addsd xmm0, [rip+doubles-@00+$00]
@00:
end;
class function CoInt.toReal(value: int): real; assembler; nostackframe;
asm
dd $000008c8
{$IFDEF WINDOWS}
mov qword [rbp-$08], rdx
fild dword [rbp-$08]
fstp tbyte [rcx+$00]
{$ELSE}
mov qword [rbp-$08], rdi
fild dword [rbp-$08]
{$ENDIF}
leave
end;
class function CoInt.toUnsignedReal(uvalue: int): real; assembler; nostackframe;
asm
dd $000008c8
{$IFDEF WINDOWS}
sub edx, $80000000
mov qword [rbp-$08], rdx
fild dword [rbp-$08]
fld qword [rip+doubles-@00+$00]
@00: faddp st(1), st
fstp tbyte [rcx+$00]
{$ELSE}
sub edi, $80000000
mov qword [rbp-$08], rdi
fild dword [rbp-$08]
fld qword [rip+doubles-@00+$00]
@00: faddp st(1), st
{$ENDIF}
leave
end;
class function CoInt.toString(value: int; radix: int): AnsiString;
var
negative: boolean;
idx: int;
len: int;
posrd: int absolute radix;
negrd: int;
buf: char_Array1d;
begin
negative := value < 0;
idx := 32;
len := idx + 1;
buf := &Array.newChar1d(len);
if (radix < CoChar.MIN_RADIX) or (radix > CoChar.MAX_RADIX) then radix := 10;
if not negative then value := -value;
negrd := -posrd;
while value <= negrd do begin
buf[idx] := CoChar.toChar(-(value mod posrd));
value := value div posrd;
dec(idx);
end;
buf[idx] := CoChar.toChar(-value);
if negative then begin
dec(idx);
buf[idx] := '-';
end;
result := AnsiString.create(buf, idx, len - idx);
end;
class function CoInt.toUnsignedString(uvalue: int; radix: int): AnsiString;
var
idx: int;
len: int;
posrd: int absolute radix;
buf: char_Array1d;
begin
idx := 31;
len := idx + 1;
buf := &Array.newChar1d(len);
if (radix < CoChar.MIN_RADIX) or (radix > CoChar.MAX_RADIX) then radix := 10;
while cmpUnsigned(uvalue, posrd) >= 0 do begin
buf[idx] := CoChar.toChar(remUnsigned(uvalue, posrd));
uvalue := divUnsigned(uvalue, posrd);
dec(idx);
end;
buf[idx] := CoChar.toChar(uvalue);
result := AnsiString.create(buf, idx, len - idx);
end;
class function CoInt.toLeadZeroString(value: int; width, radix: int): AnsiString;
var
negative: boolean;
idx: int;
len: int;
count: int;
posrd: int absolute radix;
negrd: int;
buf: char_Array1d;
begin
negative := value < 0;
idx := 32;
len := idx + 1;
buf := &Array.newChar1d(len);
if width > idx then width := idx;
if (radix < CoChar.MIN_RADIX) or (radix > CoChar.MAX_RADIX) then radix := 10;
if not negative then value := -value;
negrd := -posrd;
while value <= negrd do begin
buf[idx] := CoChar.toChar(-(value mod posrd));
value := value div posrd;
dec(idx);
end;
buf[idx] := CoChar.toChar(-value);
for count := len - idx to width - 1 do begin
dec(idx);
buf[idx] := '0';
end;
if negative then begin
dec(idx);
buf[idx] := '-';
end;
result := AnsiString.create(buf, idx, len - idx);
end;
class function CoInt.toBinaryString(uvalue: int): AnsiString;
begin
result := toUnsignedStringByShift(uvalue, 1);
end;
class function CoInt.toOctalString(uvalue: int): AnsiString;
begin
result := toUnsignedStringByShift(uvalue, 3);
end;
class function CoInt.toHexString(uvalue: int): AnsiString;
begin
result := toUnsignedStringByShift(uvalue, 4);
end;
constructor CoInt.create(const value: int);
begin
inherited create();
fldValue := value;
end;
procedure CoInt.writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 4);
int((@(dst[offset]))^) := byteSwap(fldValue);
end;
procedure CoInt.writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 4);
int((@(dst[offset]))^) := fldValue;
end;
function CoInt.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is CoInt) and (CoInt(anot).fldValue = fldValue);
end;
function CoInt.getHashCode(): long;
begin
result := fldValue;
end;
function CoInt.toString(): AnsiString;
begin
result := toString(fldValue);
end;
function CoInt.getSize(): int;
begin
result := sizeof(fldValue);
end;
function CoInt.getType(): int;
begin
result := Lang.TYPE_INT;
end;
function CoInt.isNaN(): boolean;
begin
result := false;
end;
function CoInt.isInfinite(): boolean;
begin
result := false;
end;
function CoInt.asBoolean(): boolean;
begin
result := fldValue <> 0;
end;
function CoInt.asInt(): int;
begin
result := fldValue;
end;
function CoInt.asLong(): long;
begin
result := fldValue;
end;
function CoInt.asFloat(): float;
begin
result := toFloat(fldValue);
end;
function CoInt.asDouble(): double;
begin
result := toDouble(fldValue);
end;
function CoInt.asReal(): real;
begin
result := toReal(fldValue);
end;
function CoInt.asAnsiString(): AnsiString;
begin
result := toString(fldValue);
end;
function CoInt.asUnicodeString(): UnicodeString;
begin
result := toString(fldValue).toUTF16();
end;
function CoInt.asObject(): TObject;
begin
result := self;
end;
function CoInt.asSimple(): ISimple;
begin
result := self;
end;
{%endregion}
{%region CoLong}
class function CoLong.toUnsignedStringByShift(uvalue: long; shift: int): AnsiString;
var
idx: int;
len: int;
msk: long;
buf: char_Array1d;
begin
idx := 64;
len := idx;
msk := (1 shl shift) - 1;
buf := &Array.newChar1d(len);
repeat
dec(idx);
buf[idx] := CoChar.toChar(int(uvalue and msk));
uvalue := uvalue shr shift;
until uvalue = 0;
result := AnsiString.create(buf, idx, len - idx);
end;
class function CoLong.parse(const str: AnsiString; radix: int): long;
var
negative: boolean;
idx: int;
len: int;
limit: long;
digit: long;
mulmin: long;
parsed: long;
begin
len := str.length;
if len <= 0 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
if (radix < CoChar.MIN_RADIX) or (radix > CoChar.MAX_RADIX) then begin
raise NumberFormatException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format.radix'), [ CoInt.create(radix) ]));
end;
parsed := 0;
idx := 0;
if str[1] = '-' then begin
inc(idx);
negative := true;
limit := -$8000000000000000;
end else begin
negative := false;
limit := -$7fffffffffffffff;
end;
if idx < len then begin
digit := CoChar.toDigit(str[idx + 1], radix);
if digit < 0 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
parsed := -digit;
inc(idx);
end;
mulmin := limit div radix;
while idx < len do begin
digit := CoChar.toDigit(str[idx + 1], radix);
if (digit < 0) or (parsed < mulmin) then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
parsed := parsed * radix;
if parsed < limit + digit then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
parsed := parsed - digit;
inc(idx);
end;
if negative then begin
if idx < 2 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
result := parsed;
exit;
end;
result := -parsed;
end;
class function CoLong.parseUnsigned(const str: AnsiString; radix: int): long;
var
idx: int;
len: int;
digit: long;
mulmin: long;
parsed: long;
begin
len := str.length;
if len <= 0 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
if (radix < CoChar.MIN_RADIX) or (radix > CoChar.MAX_RADIX) then begin
raise NumberFormatException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format.radix'), [ CoInt.create(radix) ]));
end;
parsed := CoChar.toDigit(str[1], radix);
if parsed < 0 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
mulmin := divUnsigned(long($ffffffffffffffff), radix);
for idx := 1 to len - 1 do begin
digit := CoChar.toDigit(str[idx + 1], radix);
if (digit < 0) or (cmpUnsigned(parsed, mulmin) > 0) then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
parsed := parsed * radix;
if cmpUnsigned(parsed, $ffffffffffffffff - digit) > 0 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
parsed := parsed + digit;
end;
result := parsed;
end;
class function CoLong.byteSwap(value: long): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
mov rax, rcx
{$ELSE}
mov rax, rdi
{$ENDIF}
bswap rax
end;
class function CoLong.bound(value, minimum, maximum: long): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cmp rcx, rdx
jge @00
mov rax, rdx
ret
@00: cmp rcx, r8
jle @01
mov rax, r8
ret
@01: mov rax, rcx
{$ELSE}
cmp rdi, rsi
jge @00
mov rax, rsi
ret
@00: cmp rdi, rdx
jle @01
mov rax, rdx
ret
@01: mov rax, rdi
{$ENDIF}
end;
class function CoLong.max(value1, value2: long): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cmp rcx, rdx
jl @00
mov rax, rcx
ret
@00: mov rax, rdx
{$ELSE}
cmp rdi, rsi
jl @00
mov rax, rdi
ret
@00: mov rax, rsi
{$ENDIF}
end;
class function CoLong.min(value1, value2: long): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cmp rcx, rdx
jg @00
mov rax, rcx
ret
@00: mov rax, rdx
{$ELSE}
cmp rdi, rsi
jg @00
mov rax, rdi
ret
@00: mov rax, rsi
{$ENDIF}
end;
class function CoLong.sar(value: long; bits: int): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
mov rax, rcx
mov ecx, edx
{$ELSE}
mov rax, rdi
mov ecx, esi
{$ENDIF}
sar rax, cl
end;
class function CoLong.rol(value: long; bits: int): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
mov rax, rcx
mov ecx, edx
{$ELSE}
mov rax, rdi
mov ecx, esi
{$ENDIF}
rol rax, cl
end;
class function CoLong.boundUnsigned(uvalue, uminimum, umaximum: long): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cmp rcx, rdx
jae @00
mov rax, rdx
ret
@00: cmp rcx, r8
jbe @01
mov rax, r8
ret
@01: mov rax, rcx
{$ELSE}
cmp rdi, rsi
jae @00
mov rax, rsi
ret
@00: cmp rdi, rdx
jbe @01
mov rax, rdx
ret
@01: mov rax, rdi
{$ENDIF}
end;
class function CoLong.cmpUnsigned(uvalue1, uvalue2: long): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cmp rcx, rdx
{$ELSE}
cmp rdi, rsi
{$ENDIF}
jb @lt
je @eq
@gt: mov eax, $00000001
ret
@lt: mov eax, $ffffffff
ret
@eq: xor eax, eax
end;
class function CoLong.divUnsigned(uvalue1, uvalue2: long): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
mov rax, rcx
mov rcx, rdx
{$ELSE}
mov rax, rdi
mov rcx, rsi
{$ENDIF}
xor rdx, rdx
div rcx
end;
class function CoLong.remUnsigned(uvalue1, uvalue2: long): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
mov rax, rcx
mov rcx, rdx
{$ELSE}
mov rax, rdi
mov rcx, rsi
{$ENDIF}
xor rdx, rdx
div rcx
mov rax, rdx
end;
class function CoLong.maxUnsigned(uvalue1, uvalue2: long): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cmp rcx, rdx
jb @00
mov rax, rcx
ret
@00: mov rax, rdx
{$ELSE}
cmp rdi, rsi
jb @00
mov rax, rdi
ret
@00: mov rax, rsi
{$ENDIF}
end;
class function CoLong.minUnsigned(uvalue1, uvalue2: long): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cmp rcx, rdx
ja @00
mov rax, rcx
ret
@00: mov rax, rdx
{$ELSE}
cmp rdi, rsi
ja @00
mov rax, rdi
ret
@00: mov rax, rsi
{$ENDIF}
end;
class function CoLong.toDoubleBits(value: long): double; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
movq xmm0, rcx
{$ELSE}
movq xmm0, rdi
{$ENDIF}
end;
class function CoLong.toFloat(value: long): float; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cvtsi2ss xmm0, rcx
{$ELSE}
cvtsi2ss xmm0, rdi
{$ENDIF}
end;
class function CoLong.toUnsignedFloat(uvalue: long): float; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
sub rcx, [rip+longs-@00+$10]
@00: cvtsi2ss xmm0, rcx
{$ELSE}
sub rdi, [rip+longs-@00+$10]
@00: cvtsi2ss xmm0, rdi
{$ENDIF}
addss xmm0, [rip+floats-@01+$04]
@01:
end;
class function CoLong.toDouble(value: long): double; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
cvtsi2sd xmm0, rcx
{$ELSE}
cvtsi2sd xmm0, rdi
{$ENDIF}
end;
class function CoLong.toUnsignedDouble(uvalue: long): double; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
sub rcx, [rip+longs-@00+$10]
@00: cvtsi2sd xmm0, rcx
{$ELSE}
sub rdi, [rip+longs-@00+$10]
@00: cvtsi2sd xmm0, rdi
{$ENDIF}
addsd xmm0, [rip+doubles-@01+$08]
@01:
end;
class function CoLong.toReal(value: long): real; assembler; nostackframe;
asm
dd $000008c8
{$IFDEF WINDOWS}
mov qword [rbp-$08], rdx
fild qword [rbp-$08]
fstp tbyte [rcx+$00]
{$ELSE}
mov qword [rbp-$08], rdi
fild qword [rbp-$08]
{$ENDIF}
leave
end;
class function CoLong.toUnsignedReal(uvalue: long): real; assembler; nostackframe;
asm
dd $000008c8
{$IFDEF WINDOWS}
sub rdx, [rip+longs-@00+$10]
@00: mov qword [rbp-$08], rdx
fild qword [rbp-$08]
fld qword [rip+doubles-@01+$08]
@01: faddp st(1), st
fstp tbyte [rcx+$00]
{$ELSE}
sub rdi, [rip+longs-@00+$10]
@00: mov qword [rbp-$08], rdi
fild qword [rbp-$08]
fld qword [rip+doubles-@01+$08]
@01: faddp st(1), st
{$ENDIF}
leave
end;
class function CoLong.toString(value: long; radix: int): AnsiString;
var
negative: boolean;
idx: int;
len: int;
posrd: long;
negrd: long;
buf: char_Array1d;
begin
negative := value < 0;
idx := 64;
len := idx + 1;
buf := &Array.newChar1d(len);
if (radix < CoChar.MIN_RADIX) or (radix > CoChar.MAX_RADIX) then radix := 10;
if not negative then value := -value;
posrd := radix;
negrd := -posrd;
while value <= negrd do begin
buf[idx] := CoChar.toChar(int(-(value mod posrd)));
value := value div posrd;
dec(idx);
end;
buf[idx] := CoChar.toChar(int(-value));
if negative then begin
dec(idx);
buf[idx] := '-';
end;
result := AnsiString.create(buf, idx, len - idx);
end;
class function CoLong.toUnsignedString(uvalue: long; radix: int): AnsiString;
var
idx: int;
len: int;
posrd: long;
buf: char_Array1d;
begin
idx := 63;
len := idx + 1;
buf := &Array.newChar1d(len);
if (radix < CoChar.MIN_RADIX) or (radix > CoChar.MAX_RADIX) then radix := 10;
posrd := radix;
while cmpUnsigned(uvalue, posrd) >= 0 do begin
buf[idx] := CoChar.toChar(int(remUnsigned(uvalue, posrd)));
uvalue := divUnsigned(uvalue, posrd);
dec(idx);
end;
buf[idx] := CoChar.toChar(int(uvalue));
result := AnsiString.create(buf, idx, len - idx);
end;
class function CoLong.toLeadZeroString(value: long; width, radix: int): AnsiString;
var
negative: boolean;
idx: int;
len: int;
count: int;
posrd: long;
negrd: long;
buf: char_Array1d;
begin
negative := value < 0;
idx := 64;
len := idx + 1;
buf := &Array.newChar1d(len);
if width > idx then width := idx;
if (radix < CoChar.MIN_RADIX) or (radix > CoChar.MAX_RADIX) then radix := 10;
if not negative then value := -value;
posrd := radix;
negrd := -posrd;
while value <= negrd do begin
buf[idx] := CoChar.toChar(int(-(value mod posrd)));
value := value div posrd;
dec(idx);
end;
buf[idx] := CoChar.toChar(int(-value));
for count := len - idx to width - 1 do begin
dec(idx);
buf[idx] := '0';
end;
if negative then begin
dec(idx);
buf[idx] := '-';
end;
result := AnsiString.create(buf, idx, len - idx);
end;
class function CoLong.toBinaryString(uvalue: long): AnsiString;
begin
result := toUnsignedStringByShift(uvalue, 1);
end;
class function CoLong.toOctalString(uvalue: long): AnsiString;
begin
result := toUnsignedStringByShift(uvalue, 3);
end;
class function CoLong.toHexString(uvalue: long): AnsiString;
begin
result := toUnsignedStringByShift(uvalue, 4);
end;
constructor CoLong.create(const value: long);
begin
inherited create();
fldValue := value;
end;
procedure CoLong.writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 8);
long((@(dst[offset]))^) := byteSwap(fldValue);
end;
procedure CoLong.writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 8);
long((@(dst[offset]))^) := fldValue;
end;
function CoLong.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is CoLong) and (CoLong(anot).fldValue = fldValue);
end;
function CoLong.getHashCode(): long;
begin
result := fldValue;
end;
function CoLong.toString(): AnsiString;
begin
result := toString(fldValue);
end;
function CoLong.getSize(): int;
begin
result := sizeof(fldValue);
end;
function CoLong.getType(): int;
begin
result := Lang.TYPE_LONG;
end;
function CoLong.isNaN(): boolean;
begin
result := false;
end;
function CoLong.isInfinite(): boolean;
begin
result := false;
end;
function CoLong.asBoolean(): boolean;
begin
result := fldValue <> 0;
end;
function CoLong.asInt(): int;
begin
result := int(fldValue);
end;
function CoLong.asLong(): long;
begin
result := fldValue;
end;
function CoLong.asFloat(): float;
begin
result := toFloat(fldValue);
end;
function CoLong.asDouble(): double;
begin
result := toDouble(fldValue);
end;
function CoLong.asReal(): real;
begin
result := toReal(fldValue);
end;
function CoLong.asAnsiString(): AnsiString;
begin
result := toString(fldValue);
end;
function CoLong.asUnicodeString(): UnicodeString;
begin
result := toString(fldValue).toUTF16();
end;
function CoLong.asObject(): TObject;
begin
result := self;
end;
function CoLong.asSimple(): ISimple;
begin
result := self;
end;
{%endregion}
{%region CoFloat}
class function CoFloat.parse(const str: AnsiString): float;
begin
result := representFloat.parseFloat(str);
end;
class function CoFloat.isNaN(value: float): boolean;
begin
result := value <> value;
end;
class function CoFloat.isInfinite(value: float): boolean;
begin
result := (value = POSITIVE_INFINITY) or (value = NEGATIVE_INFINITY);
end;
class function CoFloat.cmpl(value1, value2: float): int; assembler; nostackframe;
asm
comiss xmm0, xmm1
jp @lt
jb @lt
je @eq
@gt: mov eax, $00000001
ret
@lt: mov eax, $ffffffff
ret
@eq: xor eax, eax
end;
class function CoFloat.cmpg(value1, value2: float): int; assembler; nostackframe;
asm
comiss xmm0, xmm1
jp @gt
jb @lt
je @eq
@gt: mov eax, $00000001
ret
@lt: mov eax, $ffffffff
ret
@eq: xor eax, eax
end;
class function CoFloat.rem(value1, value2: float): float; assembler; nostackframe;
asm
dd $000008c8
movss dword [rbp-$08], xmm0
movss dword [rbp-$04], xmm1
fld dword [rbp-$04]
fld dword [rbp-$08]
@00: fprem
fnstsw ax
test eax, $00000400
jnz @00
fstp st(1)
fstp dword [rbp-$08]
movss xmm0, [rbp-$08]
leave
end;
class function CoFloat.max(value1, value2: float): float;
begin
if value1 <> value1 then begin
result := value1;
exit;
end;
if value2 <> value2 then begin
result := value2;
exit;
end;
if (value1 = 0.0) and (value2 = 0.0) and (toIntBits(value1) = CoInt.MIN_VALUE) or (value1 < value2) then begin
result := value2;
exit;
end;
result := value1;
end;
class function CoFloat.min(value1, value2: float): float;
begin
if value1 <> value1 then begin
result := value1;
exit;
end;
if value2 <> value2 then begin
result := value2;
exit;
end;
if (value1 = 0.0) and (value2 = 0.0) and (toIntBits(value2) = CoInt.MIN_VALUE) or (value1 > value2) then begin
result := value2;
exit;
end;
result := value1;
end;
class function CoFloat.bound(value, minimum, maximum: float): float;
begin
result := min(max(minimum, value), maximum);
end;
class function CoFloat.toIntBits(value: float): int; assembler; nostackframe;
asm
movd eax, xmm0
end;
class function CoFloat.toInt(value: float): int; assembler; nostackframe;
asm
movss xmm1, xmm0
movss xmm2, [rip+floats-@00+$00]
@00: movss xmm3, xmm0
cvttps2dq xmm0, xmm0
cmpss xmm1, xmm1, $07
cmpss xmm2, xmm3, $02
paddd xmm0, xmm2
pand xmm0, xmm1
movd eax, xmm0
end;
class function CoFloat.toUnsignedInt(value: float): int; assembler; nostackframe;
asm
subss xmm0, [rip+floats-@00+$00]
@00: movss xmm1, xmm0
movss xmm2, [rip+floats-@01+$00]
@01: movss xmm3, xmm0
cvttps2dq xmm0, xmm0
cmpss xmm1, xmm1, $07
cmpss xmm2, xmm3, $02
movd xmm3, [rip+ints-@02+$00]
@02: paddd xmm0, xmm3
paddd xmm0, xmm2
pand xmm0, xmm1
movd eax, xmm0
end;
class function CoFloat.toLong(value: float): long; assembler; nostackframe;
asm
cvtss2sd xmm0, xmm0
movsd xmm1, xmm0
movsd xmm2, [rip+doubles-@00+$08]
@00: movsd xmm3, xmm0
cvttsd2si rax, xmm0
movq xmm0, rax
cmpsd xmm1, xmm1, $07
cmpsd xmm2, xmm3, $02
paddq xmm0, xmm2
pand xmm0, xmm1
movq rax, xmm0
end;
class function CoFloat.toUnsignedLong(value: float): long; assembler; nostackframe;
asm
subss xmm0, [rip+floats-@00+$04]
@00: cvtss2sd xmm0, xmm0
movsd xmm1, xmm0
movsd xmm2, [rip+doubles-@01+$08]
@01: movsd xmm3, xmm0
cvttsd2si rax, xmm0
movq xmm0, rax
cmpsd xmm1, xmm1, $07
cmpsd xmm2, xmm3, $02
movq xmm3, [rip+longs-@02+$10]
@02: paddq xmm0, xmm3
paddq xmm0, xmm2
pand xmm0, xmm1
movq rax, xmm0
end;
class function CoFloat.toDouble(value: float): double; assembler; nostackframe;
asm
cvtss2sd xmm0, xmm0
end;
class function CoFloat.toReal(value: float): real; assembler; nostackframe;
asm
dd $000008c8
{$IFDEF WINDOWS}
movss dword [rbp-$08], xmm1
fld dword [rbp-$08]
fstp tbyte [rcx+$00]
{$ELSE}
movss dword [rbp-$08], xmm0
fld dword [rbp-$08]
{$ENDIF}
leave
end;
class function CoFloat.toString(value: float): AnsiString;
begin
result := representFloat.toString(toReal(value));
end;
class function CoFloat.toString(value: float; sigDigits, ordDigits: int; sigAll, ordAll, expForm, sigSign, ordSign: boolean): AnsiString;
begin
with RealRepresenter.create(sigDigits, ordDigits, sigAll, ordAll, expForm, sigSign, ordSign) do try
result := toString(toReal(value));
finally
free();
end;
end;
constructor CoFloat.create(const value: float);
begin
inherited create();
fldValue := value;
end;
procedure CoFloat.writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 4);
int((@(dst[offset]))^) := CoInt.byteSwap(toIntBits(fldValue));
end;
procedure CoFloat.writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 4);
float((@(dst[offset]))^) := fldValue;
end;
function CoFloat.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is CoFloat) and (toIntBits(CoFloat(anot).fldValue) = toIntBits(fldValue));
end;
function CoFloat.getHashCode(): long;
begin
result := toIntBits(fldValue);
end;
function CoFloat.toString(): AnsiString;
begin
result := toString(fldValue);
end;
function CoFloat.getSize(): int;
begin
result := sizeof(fldValue);
end;
function CoFloat.getType(): int;
begin
result := Lang.TYPE_FLOAT;
end;
function CoFloat.isNaN(): boolean;
begin
result := isNaN(fldValue);
end;
function CoFloat.isInfinite(): boolean;
begin
result := isInfinite(fldValue);
end;
function CoFloat.asBoolean(): boolean;
begin
result := fldValue <> 0.0;
end;
function CoFloat.asInt(): int;
begin
result := toInt(fldValue);
end;
function CoFloat.asLong(): long;
begin
result := toLong(fldValue);
end;
function CoFloat.asFloat(): float;
begin
result := fldValue;
end;
function CoFloat.asDouble(): double;
begin
result := toDouble(fldValue);
end;
function CoFloat.asReal(): real;
begin
result := toReal(fldValue);
end;
function CoFloat.asAnsiString(): AnsiString;
begin
result := toString(fldValue);
end;
function CoFloat.asUnicodeString(): UnicodeString;
begin
result := toString(fldValue).toUTF16();
end;
function CoFloat.asObject(): TObject;
begin
result := self;
end;
function CoFloat.asSimple(): ISimple;
begin
result := self;
end;
{%endregion}
{%region CoDouble}
class function CoDouble.parse(const str: AnsiString): double;
begin
result := representDouble.parseDouble(str);
end;
class function CoDouble.isNaN(value: double): boolean;
begin
result := value <> value;
end;
class function CoDouble.isInfinite(value: double): boolean;
begin
result := (value = POSITIVE_INFINITY) or (value = NEGATIVE_INFINITY);
end;
class function CoDouble.cmpl(value1, value2: double): int; assembler; nostackframe;
asm
comisd xmm0, xmm1
jp @lt
jb @lt
je @eq
@gt: mov eax, $00000001
ret
@lt: mov eax, $ffffffff
ret
@eq: xor eax, eax
end;
class function CoDouble.cmpg(value1, value2: double): int; assembler; nostackframe;
asm
comisd xmm0, xmm1
jp @gt
jb @lt
je @eq
@gt: mov eax, $00000001
ret
@lt: mov eax, $ffffffff
ret
@eq: xor eax, eax
end;
class function CoDouble.rem(value1, value2: double): double; assembler; nostackframe;
asm
dd $000010c8
movsd qword [rbp-$10], xmm0
movsd qword [rbp-$08], xmm1
fld qword [rbp-$08]
fld qword [rbp-$10]
@00: fprem
fnstsw ax
test eax, $00000400
jnz @00
fstp st(1)
fstp qword [rbp-$10]
movsd xmm0, [rbp-$10]
leave
end;
class function CoDouble.max(value1, value2: double): double;
begin
if value1 <> value1 then begin
result := value1;
exit;
end;
if value2 <> value2 then begin
result := value2;
exit;
end;
if (value1 = 0.0) and (value2 = 0.0) and (toLongBits(value1) = CoLong.MIN_VALUE) or (value1 < value2) then begin
result := value2;
exit;
end;
result := value1;
end;
class function CoDouble.min(value1, value2: double): double;
begin
if value1 <> value1 then begin
result := value1;
exit;
end;
if value2 <> value2 then begin
result := value2;
exit;
end;
if (value1 = 0.0) and (value2 = 0.0) and (toLongBits(value2) = CoLong.MIN_VALUE) or (value1 > value2) then begin
result := value2;
exit;
end;
result := value1;
end;
class function CoDouble.bound(value, minimum, maximum: double): double;
begin
result := min(max(minimum, value), maximum);
end;
class function CoDouble.toLongBits(value: double): long; assembler; nostackframe;
asm
movq rax, xmm0
end;
class function CoDouble.toInt(value: double): int; assembler; nostackframe;
asm
movsd xmm1, xmm0
movsd xmm2, [rip+doubles-@00+$00]
@00: movsd xmm3, xmm0
cvttpd2dq xmm0, xmm0
cmpsd xmm1, xmm1, $07
cmpsd xmm2, xmm3, $02
paddd xmm0, xmm2
pand xmm0, xmm1
movd eax, xmm0
end;
class function CoDouble.toUnsignedInt(value: double): int; assembler; nostackframe;
asm
subsd xmm0, [rip+doubles-@00+$00]
@00: movsd xmm1, xmm0
movsd xmm2, [rip+doubles-@01+$00]
@01: movsd xmm3, xmm0
cvttpd2dq xmm0, xmm0
cmpsd xmm1, xmm1, $07
cmpsd xmm2, xmm3, $02
movd xmm3, [rip+ints-@02+$00]
@02: paddd xmm0, xmm3
paddd xmm0, xmm2
pand xmm0, xmm1
movd eax, xmm0
end;
class function CoDouble.toLong(value: double): long; assembler; nostackframe;
asm
movsd xmm1, xmm0
movsd xmm2, [rip+doubles-@00+$08]
@00: movsd xmm3, xmm0
cvttsd2si rax, xmm0
movq xmm0, rax
cmpsd xmm1, xmm1, $07
cmpsd xmm2, xmm3, $02
paddq xmm0, xmm2
pand xmm0, xmm1
movq rax, xmm0
end;
class function CoDouble.toUnsignedLong(value: double): long; assembler; nostackframe;
asm
subsd xmm0, [rip+doubles-@00+$08]
@00: movsd xmm1, xmm0
movsd xmm2, [rip+doubles-@01+$08]
@01: movsd xmm3, xmm0
cvttsd2si rax, xmm0
movq xmm0, rax
cmpsd xmm1, xmm1, $07
cmpsd xmm2, xmm3, $02
movq xmm3, [rip+longs-@02+$10]
@02: paddq xmm0, xmm3
paddq xmm0, xmm2
pand xmm0, xmm1
movq rax, xmm0
end;
class function CoDouble.toFloat(value: double): float; assembler; nostackframe;
asm
cvtsd2ss xmm0, xmm0
end;
class function CoDouble.toReal(value: double): real; assembler; nostackframe;
asm
dd $000008c8
{$IFDEF WINDOWS}
movsd qword [rbp-$08], xmm1
fld qword [rbp-$08]
fstp tbyte [rcx+$00]
{$ELSE}
movsd qword [rbp-$08], xmm0
fld qword [rbp-$08]
{$ENDIF}
leave
end;
class function CoDouble.toString(value: double): AnsiString;
begin
result := representDouble.toString(toReal(value));
end;
class function CoDouble.toString(value: double; sigDigits, ordDigits: int; sigAll, ordAll, expForm, sigSign, ordSign: boolean): AnsiString;
begin
with RealRepresenter.create(sigDigits, ordDigits, sigAll, ordAll, expForm, sigSign, ordSign) do try
result := toString(toReal(value));
finally
free();
end;
end;
constructor CoDouble.create(const value: double);
begin
inherited create();
fldValue := value;
end;
procedure CoDouble.writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 8);
long((@(dst[offset]))^) := CoLong.byteSwap(toLongBits(fldValue));
end;
procedure CoDouble.writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 8);
double((@(dst[offset]))^) := fldValue;
end;
function CoDouble.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is CoDouble) and (toLongBits(CoDouble(anot).fldValue) = toLongBits(fldValue));
end;
function CoDouble.getHashCode(): long;
begin
result := toLongBits(fldValue);
end;
function CoDouble.toString(): AnsiString;
begin
result := toString(fldValue);
end;
function CoDouble.getSize(): int;
begin
result := sizeof(fldValue);
end;
function CoDouble.getType(): int;
begin
result := Lang.TYPE_DOUBLE;
end;
function CoDouble.isNaN(): boolean;
begin
result := isNaN(fldValue);
end;
function CoDouble.isInfinite(): boolean;
begin
result := isInfinite(fldValue);
end;
function CoDouble.asBoolean(): boolean;
begin
result := fldValue <> 0.0;
end;
function CoDouble.asInt(): int;
begin
result := toInt(fldValue);
end;
function CoDouble.asLong(): long;
begin
result := toLong(fldValue);
end;
function CoDouble.asFloat(): float;
begin
result := toFloat(fldValue);
end;
function CoDouble.asDouble(): double;
begin
result := fldValue;
end;
function CoDouble.asReal(): real;
begin
result := toReal(fldValue);
end;
function CoDouble.asAnsiString(): AnsiString;
begin
result := toString(fldValue);
end;
function CoDouble.asUnicodeString(): UnicodeString;
begin
result := toString(fldValue).toUTF16();
end;
function CoDouble.asObject(): TObject;
begin
result := self;
end;
function CoDouble.asSimple(): ISimple;
begin
result := self;
end;
{%endregion}
{%region CoReal}
{$IFDEF WINDOWS}
class function CoReal.MIN_VALUE: real;
begin
result := CoReal.build($0000, $0000000000000001); { минимальное значение }
end;
class function CoReal.MAX_VALUE: real;
begin
result := CoReal.build($7ffe, $ffffffffffffffff); { максимальное значение }
end;
class function CoReal.POSITIVE_INFINITY: real;
begin
result := CoReal.build($7fff, $8000000000000000); { +∞ }
end;
class function CoReal.NEGATIVE_INFINITY: real;
begin
result := CoReal.build($ffff, $8000000000000000); { –∞ }
end;
class function CoReal.NEGATIVE_ZERO: real;
begin
result := CoReal.build($8000, $0000000000000000); { –0 }
end;
class function CoReal.NAN: real;
begin
result := CoReal.build($ffff, $c000000000000000); { не число }
end;
{$ENDIF}
class function CoReal.parse(const str: AnsiString): real;
begin
result := representReal.parseReal(str);
end;
class function CoReal.isNaN(value: real): boolean;
begin
result := value <> value;
end;
class function CoReal.isInfinite(value: real): boolean;
begin
result := (value = POSITIVE_INFINITY) or (value = NEGATIVE_INFINITY);
end;
class function CoReal.cmpl(value1, value2: real): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
fld tbyte [rcx+$00]
{$ELSE}
fld tbyte [rsp+$18]
fld tbyte [rsp+$08]
{$ENDIF}
fcomip st, st(1)
ffree st
fincstp
jp @lt
jb @lt
je @eq
@gt: mov eax, $00000001
ret
@lt: mov eax, $ffffffff
ret
@eq: xor eax, eax
end;
class function CoReal.cmpg(value1, value2: real): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
fld tbyte [rcx+$00]
{$ELSE}
fld tbyte [rsp+$18]
fld tbyte [rsp+$08]
{$ENDIF}
fcomip st, st(1)
ffree st
fincstp
jp @gt
jb @lt
je @eq
@gt: mov eax, $00000001
ret
@lt: mov eax, $ffffffff
ret
@eq: xor eax, eax
end;
class function CoReal.rem(value1, value2: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [r8+$00]
fld tbyte [rdx+$00]
@00: fprem
fnstsw ax
test eax, $00000400
jnz @00
fstp st(1)
fstp tbyte [rcx+$00]
{$ELSE}
fld tbyte [rsp+$18]
fld tbyte [rsp+$08]
@00: fprem
fnstsw ax
test eax, $00000400
jnz @00
fstp st(1)
{$ENDIF}
end;
class function CoReal.max(value1, value2: real): real;
begin
if value1 <> value1 then begin
result := value1;
exit;
end;
if value2 <> value2 then begin
result := value2;
exit;
end;
if (value1 = 0.0) and (value2 = 0.0) and (extractExponent(value1) = CoShort.MIN_VALUE) and (extractSignificand(value1) = 0) or (value1 < value2) then begin
result := value2;
exit;
end;
result := value1;
end;
class function CoReal.min(value1, value2: real): real;
begin
if value1 <> value1 then begin
result := value1;
exit;
end;
if value2 <> value2 then begin
result := value2;
exit;
end;
if (value1 = 0.0) and (value2 = 0.0) and (extractExponent(value2) = CoShort.MIN_VALUE) and (extractSignificand(value2) = 0) or (value1 > value2) then begin
result := value2;
exit;
end;
result := value1;
end;
class function CoReal.bound(value, minimum, maximum: real): real;
begin
result := min(max(minimum, value), maximum);
end;
class function CoReal.extractExponent(const value: real): int;
var
struct: RealStruct absolute value;
begin
result := struct.exponent;
end;
class function CoReal.extractSignificand(const value: real): long;
var
struct: RealStruct absolute value;
begin
result := struct.significand;
end;
class function CoReal.build(exponent: int; significand: long): real;
var
struct: RealStruct absolute result;
begin
struct.significand := significand;
struct.exponent := short(exponent);
end;
class function CoReal.toInt(value: real): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rcx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fild qword [rip+longs-@00+$00]
@00: fcomip st, st(1)
jnp @01
ffree st
fincstp
xor eax, eax
ret
@01: ja @02
ffree st
fincstp
mov eax, $7fffffff
ret
@02: lea rsp, [rsp-$08]
fisttp dword [rsp+$00]
pop rax
mov eax, eax
end;
class function CoReal.toUnsignedInt(value: real): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rcx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fild dword [rip+ints-@00+$00]
@00: faddp st(1), st
fild qword [rip+longs-@01+$00]
@01: fcomip st, st(1)
jnp @02
ffree st
fincstp
xor eax, eax
ret
@02: ja @03
ffree st
fincstp
mov eax, $ffffffff
ret
@03: lea rsp, [rsp-$08]
fisttp dword [rsp+$00]
pop rax
add eax, $80000000
end;
class function CoReal.toLong(value: real): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rcx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fild qword [rip+longs-@00+$08]
@00: fcomip st, st(1)
jnp @01
ffree st
fincstp
xor eax, eax
ret
@01: ja @03
ffree st
fincstp
mov rax, [rip+longs-@02+$08]
@02: ret
@03: lea rsp, [rsp-$08]
fisttp qword [rsp+$00]
pop rax
end;
class function CoReal.toUnsignedLong(value: real): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rcx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fild qword [rip+longs-@00+$10]
@00: faddp st(1), st
fild qword [rip+longs-@01+$08]
@01: fcomip st, st(1)
jnp @02
ffree st
fincstp
xor eax, eax
ret
@02: ja @04
ffree st
fincstp
mov rax, [rip+longs-@03+$18]
@03: ret
@04: lea rsp, [rsp-$08]
fisttp qword [rsp+$00]
pop rax
add rax, [rip+longs-@05+$10]
@05:
end;
class function CoReal.toFloat(value: real): float; assembler; nostackframe;
asm
dd $000008c8
{$IFDEF WINDOWS}
fld tbyte [rcx+$00]
{$ELSE}
fld tbyte [value+$00]
{$ENDIF}
fstp dword [rbp-$08]
movss xmm0, [rbp-$08]
leave
end;
class function CoReal.toDouble(value: real): double; assembler; nostackframe;
asm
dd $000008c8
{$IFDEF WINDOWS}
fld tbyte [rcx+$00]
{$ELSE}
fld tbyte [value+$00]
{$ENDIF}
fstp qword [rbp-$08]
movsd xmm0, [rbp-$08]
leave
end;
class function CoReal.toString(value: real): AnsiString;
begin
result := representReal.toString(value);
end;
class function CoReal.toString(value: real; sigDigits, ordDigits: int; sigAll, ordAll, expForm, sigSign, ordSign: boolean): AnsiString;
begin
with RealRepresenter.create(sigDigits, ordDigits, sigAll, ordAll, expForm, sigSign, ordSign) do try
result := toString(value);
finally
free();
end;
end;
constructor CoReal.create(const value: real);
begin
inherited create();
fldValue := value;
end;
procedure CoReal.writeToByteArrayBigEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 10);
short((@(dst[offset]))^) := CoShort.byteSwap(RealStruct(fldValue).exponent);
long((@(dst[offset + 2]))^) := CoLong.byteSwap(RealStruct(fldValue).significand);
end;
procedure CoReal.writeToByteArrayLittleEndian(const dst: byte_Array1d; offset: int);
begin
&Array.checkBounds(dst, offset, 10);
real((@(dst[offset]))^) := fldValue;
end;
function CoReal.equals(anot: TObject): boolean;
begin
result := (anot = self) or (
(anot is CoReal) and
(RealStruct(CoReal(anot).fldValue).exponent = RealStruct(fldValue).exponent) and
(RealStruct(CoReal(anot).fldValue).significand = RealStruct(fldValue).significand)
);
end;
function CoReal.getHashCode(): long;
begin
result := CoDouble.toLongBits(toDouble(fldValue));
end;
function CoReal.toString(): AnsiString;
begin
result := toString(fldValue);
end;
function CoReal.getSize(): int;
begin
result := sizeof(fldValue);
end;
function CoReal.getType(): int;
begin
result := Lang.TYPE_REAL;
end;
function CoReal.isNaN(): boolean;
begin
result := isNaN(fldValue);
end;
function CoReal.isInfinite(): boolean;
begin
result := isInfinite(fldValue);
end;
function CoReal.asBoolean(): boolean;
begin
result := fldValue <> 0.0;
end;
function CoReal.asInt(): int;
begin
result := toInt(fldValue);
end;
function CoReal.asLong(): long;
begin
result := toLong(fldValue);
end;
function CoReal.asFloat(): float;
begin
result := toFloat(fldValue);
end;
function CoReal.asDouble(): double;
begin
result := toDouble(fldValue);
end;
function CoReal.asReal(): real;
begin
result := fldValue;
end;
function CoReal.asAnsiString(): AnsiString;
begin
result := toString(fldValue);
end;
function CoReal.asUnicodeString(): UnicodeString;
begin
result := toString(fldValue).toUTF16();
end;
function CoReal.asObject(): TObject;
begin
result := self;
end;
function CoReal.asSimple(): ISimple;
begin
result := self;
end;
{%endregion}
{%region CoAnsiString}
constructor CoAnsiString.create(const value: AnsiString);
begin
inherited create();
fldValue := value;
end;
function CoAnsiString.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is CoAnsiString) and (CoAnsiString(anot).fldValue = fldValue);
end;
function CoAnsiString.getHashCode(): long;
var
idx: int;
mul: long;
str: AnsiString;
begin
if fldHashComputed then begin
result := fldHashValue;
exit;
end;
result := 0;
mul := 1;
str := fldValue;
for idx := 0 to str.length - 1 do begin
inc(result, mul * int(str[idx + 1]));
mul := 31 * mul;
end;
fldHashValue := result;
fldHashComputed := true;
end;
function CoAnsiString.toString(): AnsiString;
begin
result := fldValue;
end;
function CoAnsiString.getType(): int;
begin
result := Lang.TYPE_ANSISTRING;
end;
function CoAnsiString.isNaN(): boolean;
begin
result := false;
end;
function CoAnsiString.isInfinite(): boolean;
begin
result := false;
end;
function CoAnsiString.asBoolean(): boolean;
begin
result := fldValue.length > 0;
end;
function CoAnsiString.asInt(): int;
begin
try
result := CoInt.parse(fldValue);
except
result := 0;
end;
end;
function CoAnsiString.asLong(): long;
begin
try
result := CoLong.parse(fldValue);
except
result := 0;
end;
end;
function CoAnsiString.asFloat(): float;
begin
try
result := CoFloat.parse(fldValue);
except
result := 0;
end;
end;
function CoAnsiString.asDouble(): double;
begin
try
result := CoDouble.parse(fldValue);
except
result := 0;
end;
end;
function CoAnsiString.asReal(): real;
begin
try
result := CoReal.parse(fldValue);
except
result := 0;
end;
end;
function CoAnsiString.asAnsiString(): AnsiString;
begin
result := fldValue;
end;
function CoAnsiString.asUnicodeString(): UnicodeString;
begin
result := fldValue.toUTF16();
end;
function CoAnsiString.asObject(): TObject;
begin
result := self;
end;
function CoAnsiString.asSimple(): ISimple;
begin
result := self;
end;
{%endregion}
{%region CoUnicodeString}
constructor CoUnicodeString.create(const value: UnicodeString);
begin
inherited create();
fldValue := value;
end;
function CoUnicodeString.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is CoUnicodeString) and (CoUnicodeString(anot).fldValue = fldValue);
end;
function CoUnicodeString.getHashCode(): long;
var
idx: int;
mul: long;
str: UnicodeString;
begin
if fldHashComputed then begin
result := fldHashValue;
exit;
end;
result := 0;
mul := 1;
str := fldValue;
for idx := 0 to str.length - 1 do begin
inc(result, mul * int(str[idx + 1]));
mul := 31 * mul;
end;
fldHashValue := result;
fldHashComputed := true;
end;
function CoUnicodeString.toString(): AnsiString;
begin
result := fldValue.toUTF8();
end;
function CoUnicodeString.getType(): int;
begin
result := Lang.TYPE_UNICODESTRING;
end;
function CoUnicodeString.isNaN(): boolean;
begin
result := false;
end;
function CoUnicodeString.isInfinite(): boolean;
begin
result := false;
end;
function CoUnicodeString.asBoolean(): boolean;
begin
result := fldValue.length > 0;
end;
function CoUnicodeString.asInt(): int;
begin
try
result := CoInt.parse(fldValue.toUTF8());
except
result := 0;
end;
end;
function CoUnicodeString.asLong(): long;
begin
try
result := CoLong.parse(fldValue.toUTF8());
except
result := 0;
end;
end;
function CoUnicodeString.asFloat(): float;
begin
try
result := CoFloat.parse(fldValue.toUTF8());
except
result := 0;
end;
end;
function CoUnicodeString.asDouble(): double;
begin
try
result := CoDouble.parse(fldValue.toUTF8());
except
result := 0;
end;
end;
function CoUnicodeString.asReal(): real;
begin
try
result := CoReal.parse(fldValue.toUTF8());
except
result := 0;
end;
end;
function CoUnicodeString.asAnsiString(): AnsiString;
begin
result := fldValue.toUTF8();
end;
function CoUnicodeString.asUnicodeString(): UnicodeString;
begin
result := fldValue;
end;
function CoUnicodeString.asObject(): TObject;
begin
result := self;
end;
function CoUnicodeString.asSimple(): ISimple;
begin
result := self;
end;
{%endregion}
{%region CoObject}
constructor CoObject.create(const value: TObject);
begin
inherited create();
fldValue := value;
end;
function CoObject.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is CoObject) and (CoObject(anot).fldValue = fldValue);
end;
function CoObject.getHashCode(): long;
begin
result := long(fldValue);
end;
function CoObject.toString(): AnsiString;
var
obj: TObject;
begin
obj := fldValue;
if obj = nil then begin
result := 'null';
exit;
end;
result := obj.toString();
end;
function CoObject.getType(): int;
begin
result := Lang.TYPE_OBJECT;
end;
function CoObject.isNaN(): boolean;
begin
result := false;
end;
function CoObject.isInfinite(): boolean;
begin
result := false;
end;
function CoObject.asBoolean(): boolean;
begin
result := false;
end;
function CoObject.asInt(): int;
begin
result := 0;
end;
function CoObject.asLong(): long;
begin
result := 0;
end;
function CoObject.asFloat(): float;
begin
result := 0;
end;
function CoObject.asDouble(): double;
begin
result := 0;
end;
function CoObject.asReal(): real;
begin
result := 0;
end;
function CoObject.asAnsiString(): AnsiString;
begin
result := '';
end;
function CoObject.asUnicodeString(): UnicodeString;
begin
result := '';
end;
function CoObject.asObject(): TObject;
begin
result := fldValue;
end;
function CoObject.asSimple(): ISimple;
var
val: TObject;
ref: ISimple;
begin
val := fldValue;
if (val <> nil) and val.getInterface(getTypeData(PTypeInfo(typeInfo(ISimple)))^.iidStr, ref) then begin
result := ref;
exit;
end;
result := nil;
end;
{%endregion}
{%region CoSimple}
constructor CoSimple.create(const value: ISimple);
begin
inherited create();
fldValue := value;
end;
function CoSimple.equals(anot: TObject): boolean;
var
ref1: ISimple;
ref2: ISimple;
piid: system.PGuid;
begin
if anot = self then begin
result := true;
exit;
end;
if not(anot is CoSimple) then begin
result := false;
exit;
end;
ref1 := fldValue;
ref2 := CoSimple(anot).fldValue;
piid := @(getTypeData(PTypeInfo(typeInfo(ISimple)))^.guid);
if
((ref1 = nil) or (ref1.queryInterface(piid^, ref1) = system.S_OK)) and
((ref2 = nil) or (ref2.queryInterface(piid^, ref2) = system.S_OK))
then begin
result := ref1 = ref2;
exit;
end;
result := false;
end;
function CoSimple.getHashCode(): long;
var
ref: ISimple;
begin
ref := fldValue;
if ref <> nil then begin
ref.queryInterface(getTypeData(PTypeInfo(typeInfo(ISimple)))^.guid, ref);
end;
result := long(ref);
end;
function CoSimple.toString(): AnsiString;
var
obj: TObject;
ref: ISimple;
begin
ref := fldValue;
if (ref = nil) or (ref.queryInterface(IObjectInstance, obj) <> system.S_OK) then begin
result := 'null';
exit;
end;
result := obj.toString();
end;
function CoSimple.getType(): int;
begin
result := Lang.TYPE_INTERFACE_RAW;
end;
function CoSimple.isNaN(): boolean;
begin
result := false;
end;
function CoSimple.isInfinite(): boolean;
begin
result := false;
end;
function CoSimple.asBoolean(): boolean;
begin
result := false;
end;
function CoSimple.asInt(): int;
begin
result := 0;
end;
function CoSimple.asLong(): long;
begin
result := 0;
end;
function CoSimple.asFloat(): float;
begin
result := 0;
end;
function CoSimple.asDouble(): double;
begin
result := 0;
end;
function CoSimple.asReal(): real;
begin
result := 0;
end;
function CoSimple.asAnsiString(): AnsiString;
begin
result := '';
end;
function CoSimple.asUnicodeString(): UnicodeString;
begin
result := '';
end;
function CoSimple.asObject(): TObject;
var
obj: TObject;
ref: ISimple;
begin
ref := fldValue;
if (ref = nil) or (ref.queryInterface(IObjectInstance, obj) <> system.S_OK) then begin
result := nil;
exit;
end;
result := obj;
end;
function CoSimple.asSimple(): ISimple;
begin
result := fldValue;
end;
{%endregion}
{%region CoUnknown}
constructor CoUnknown.create(const value: IUnknown);
begin
inherited create();
fldValue := value;
end;
function CoUnknown.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is CoUnknown) and ((CoUnknown(anot).fldValue as IUnknown) = (fldValue as IUnknown));
end;
function CoUnknown.getHashCode(): long;
begin
result := long(fldValue as IUnknown);
end;
function CoUnknown.toString(): AnsiString;
var
obj: TObject;
ref: IUnknown;
begin
ref := fldValue;
if (ref = nil) or (ref.queryInterface(IObjectInstance, obj) <> system.S_OK) then begin
result := 'null';
exit;
end;
result := obj.toString();
end;
function CoUnknown.getType(): int;
begin
result := Lang.TYPE_INTERFACE_RC;
end;
function CoUnknown.isNaN(): boolean;
begin
result := false;
end;
function CoUnknown.isInfinite(): boolean;
begin
result := false;
end;
function CoUnknown.asBoolean(): boolean;
begin
result := false;
end;
function CoUnknown.asInt(): int;
begin
result := 0;
end;
function CoUnknown.asLong(): long;
begin
result := 0;
end;
function CoUnknown.asFloat(): float;
begin
result := 0;
end;
function CoUnknown.asDouble(): double;
begin
result := 0;
end;
function CoUnknown.asReal(): real;
begin
result := 0;
end;
function CoUnknown.asAnsiString(): AnsiString;
begin
result := '';
end;
function CoUnknown.asUnicodeString(): UnicodeString;
begin
result := '';
end;
function CoUnknown.asObject(): TObject;
var
obj: TObject;
ref: IUnknown;
begin
ref := fldValue;
if (ref = nil) or (ref.queryInterface(IObjectInstance, obj) <> system.S_OK) then begin
result := nil;
exit;
end;
result := obj;
end;
function CoUnknown.asSimple(): ISimple;
begin
result := ISimple(Pointer(fldValue));
end;
{%endregion}
{%region RealRepresenter}
class function RealRepresenter.tab_04_00(power: int): real;
begin
case power and $1f of
0: result := 1;
1: result := reals[5].value;
2: result := reals[6].value;
3: result := reals[7].value;
4: result := reals[8].value;
5: result := reals[9].value;
6: result := reals[10].value;
7: result := reals[11].value;
8: result := reals[12].value;
9: result := reals[13].value;
10: result := reals[14].value;
11: result := reals[15].value;
12: result := reals[16].value;
13: result := reals[17].value;
14: result := reals[18].value;
15: result := reals[19].value;
16: result := reals[20].value;
17: result := reals[21].value;
18: result := reals[22].value;
19: result := reals[23].value;
20: result := reals[24].value;
21: result := reals[25].value;
22: result := reals[26].value;
23: result := reals[27].value;
24: result := reals[28].value;
25: result := reals[29].value;
26: result := reals[30].value;
27: result := reals[31].value;
28: result := reals[32].value;
29: result := reals[33].value;
30: result := reals[34].value;
31: result := reals[35].value;
else result := 0;
end;
end;
class function RealRepresenter.tab_08_05(power: int): real;
begin
case (power shr 5) and $0f of
0: result := 1;
1: result := reals[36].value;
2: result := reals[37].value;
3: result := reals[38].value;
4: result := reals[39].value;
5: result := reals[40].value;
6: result := reals[41].value;
7: result := reals[42].value;
8: result := reals[43].value;
9: result := reals[44].value;
10: result := reals[45].value;
11: result := reals[46].value;
12: result := reals[47].value;
13: result := reals[48].value;
14: result := reals[49].value;
15: result := reals[50].value;
else result := 0;
end;
end;
class function RealRepresenter.tab_12_09(power: int): real;
begin
case (power shr 9) and $0f of
0: result := 1;
1: result := reals[51].value;
2: result := reals[52].value;
3: result := reals[53].value;
4: result := reals[54].value;
5: result := reals[55].value;
6: result := reals[56].value;
7: result := reals[57].value;
8: result := reals[58].value;
9: result := reals[59].value;
else result := CoReal.POSITIVE_INFINITY;
end;
end;
class function RealRepresenter.round(value: real): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rcx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fild qword [rip+longs-@00+$08]
@00: fcomip st, st(1)
jnp @01
ffree st
fincstp
xor eax, eax
ret
@01: ja @03
ffree st
fincstp
mov rax, [rip+longs-@02+$08]
@02: ret
@03: lea rsp, [rsp-$08]
fistp qword [rsp+$00]
pop rax
end;
class function RealRepresenter.pow10(value: real; power: int): real;
begin
if power = CoInt.MIN_VALUE then begin
result := value * real(0);
exit;
end;
if power > 0 then begin
if power >= $2000 then begin
result := value * tab_04_00(power) * tab_08_05(power) * tab_12_09(power) * CoReal.POSITIVE_INFINITY;
exit;
end;
result := value * tab_04_00(power) * tab_08_05(power) * tab_12_09(power);
exit;
end;
if power < 0 then begin
power := -power;
if power >= $2000 then begin
result := value / tab_04_00(power) / tab_08_05(power) / tab_12_09(power) * real(0);
exit;
end;
result := value / tab_04_00(power) / tab_08_05(power) / tab_12_09(power);
exit;
end;
result := value;
end;
function RealRepresenter.parse(const str: AnsiString): real;
var
negative: boolean;
character: char;
idx: int;
len: int;
frac: int;
order: int;
temp: long;
digit: long;
intValue: long;
parsed: real;
begin
len := str.length;
if 0 >= len then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
negative := false;
idx := 0;
frac := 0;
order := 0;
intValue := 0;
character := str[1];
case character of
' ', '-', '+': begin
if character = '-' then begin
negative := true;
end;
inc(idx);
if idx >= len then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
character := str[idx + 1];
end;
end;
if ((character < '0') or (character > '9')) and (character <> '.') then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
if character <> '.' then begin
intValue := int(character) - int('0');
repeat
inc(idx);
if idx >= len then break;
character := str[idx + 1];
if (character < '0') or (character > '9') then break;
digit := int(character) - int('0');
temp := intValue * 10;
if (intValue > MUL_MIN) or (temp > CoLong.MAX_VALUE - digit) then begin
dec(frac);
end else begin
intValue := temp + digit;
end;
until false;
end;
if (idx < len) and (str[idx + 1] = '.') then begin
repeat
inc(idx);
if idx >= len then break;
character := str[idx + 1];
if (character < '0') or (character > '9') then break;
digit := int(character) - int('0');
temp := intValue * 10;
if (intValue <= MUL_MIN) and (temp <= CoLong.MAX_VALUE - digit) then begin
inc(frac);
intValue := temp + digit;
end;
until false;
end;
if intValue > 0 then while (frac > 0) and (intValue mod 10 = 0) do begin
dec(frac);
intValue := intValue div 10;
end;
parsed := CoLong.toReal(intValue);
if negative then begin
negative := false;
parsed := parsed / real(-1);
end;
if idx < len then begin
character := str[idx + 1];
if (character = 'E') or (character = 'e') then begin
inc(idx);
if idx >= len then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
character := str[idx + 1];
case character of
'-', '+': begin
if character = '-' then begin
negative := true;
end;
inc(idx);
if idx >= len then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
character := str[idx + 1];
end;
end;
if (character < '0') or (character > '9') then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
order := int(character) - int('0');
repeat
inc(idx);
if idx >= len then break;
character := str[idx + 1];
if (character < '0') or (character > '9') then break;
order := 10 * order + int(character) - int('0');
if order > 9999 then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
until false;
if negative then order := -order;
end;
end;
if idx < len then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
result := pow10(parsed, order - frac);
end;
function RealRepresenter.represent(value: real): char_Array1d;
var
expForm: boolean;
character: char;
idx: int;
len: int;
order: int;
dotIdx: int;
ordDigits: int;
ordLength: int;
sigDigits: int;
intVal: long;
maxVal: long;
minVal: real;
bits: RealStruct;
buf: char_Array1d;
cpy: char_Array1d;
begin
buf := &Array.newChar1d(32);
&Array.fillPrimitives(buf, 0, 32, '0');
bits.value := value;
len := 0;
if bits.exponent < 0 then begin
buf[len] := '-';
inc(len);
value := value / real(-1);
end else
if fldSigSign then begin
buf[len] := '+';
inc(len);
end;
if (bits.exponent and $7fff = 0) and (bits.significand = 0) then begin
buf[len + 1] := '.';
if fldSigAll then begin
inc(len, fldSigDigits + 1);
end else begin
inc(len, 3);
end;
if fldExpForm then begin
buf[len] := 'E';
inc(len);
if fldOrdSign then begin
buf[len] := '+';
inc(len);
end;
if fldOrdAll then begin
inc(len, fldOrdDigits);
end else begin
inc(len);
end;
end;
end else begin
sigDigits := fldSigDigits;
minVal := pow10(1, -CoInt.min(6, sigDigits));
order := CoReal.toInt(Math.floor(Math.log10(value)));
expForm := fldExpForm or (value < minVal) or (value >= fldLimitValueWithoutExponent);
if expForm then begin
intVal := round(pow10(value, sigDigits - order - 1));
if intVal < fldMinRepresentValue then begin
intVal := intVal * 10;
dec(order);
end;
if intVal > fldMaxRepresentValue then begin
intVal := intVal div 10;
inc(order);
end;
dotIdx := len + 1;
end else
if value < 1 then begin
intVal := round(pow10(value, sigDigits - 1));
dotIdx := len + 1;
end else
if value < fldLimitValueWithFractialPart then begin
intVal := round(pow10(value, sigDigits - order - 1));
if intVal < fldMinRepresentValue then begin
intVal := intVal * 10;
dec(order);
end;
if intVal > fldMaxRepresentValue then begin
intVal := intVal div 10;
inc(order);
end;
dotIdx := len + order + 1;
end else begin
intVal := round(value);
maxVal := fldMaxRepresentValue;
if intVal > maxVal then intVal := maxVal;
dotIdx := len + sigDigits;
end;
buf[dotIdx] := '.';
for idx := len + sigDigits - 1 downto len do begin
if idx < dotIdx then begin
buf[idx] := char((intVal mod 10) + int('0'));
end else begin
buf[idx + 1] := char((intVal mod 10) + int('0'));
end;
intVal := intVal div 10;
end;
inc(len, sigDigits + 1);
if not fldSigAll then repeat
character := buf[len - 1];
if (character <> '0') and (character <> '.') then break;
dec(len);
if character = '.' then begin
inc(len, 2);
break;
end;
until false;
if expForm then begin
buf[len] := 'E';
inc(len);
if order < 0 then begin
buf[len] := '-';
inc(len);
order := -order;
end else
if fldOrdSign then begin
buf[len] := '+';
inc(len);
end;
if fldOrdAll then begin
ordDigits := fldOrdDigits;
end else begin
ordDigits := 1;
end;
if (ordDigits = 1) and (order >= 10) then inc(ordDigits);
if (ordDigits = 2) and (order >= 100) then inc(ordDigits);
if (ordDigits = 3) and (order >= 1000) then inc(ordDigits);
ordLength := len + ordDigits;
for idx := ordLength - 1 downto len do begin
buf[idx] := char((order mod 10) + int('0'));
order := order div 10;
end;
len := ordLength;
end;
end;
if len >= 32 then begin
result := buf;
exit;
end;
cpy := &Array.newChar1d(len);
&Array.copyPrimitives(buf, 0, cpy, 0, len);
result := cpy;
end;
constructor RealRepresenter.create(sigDigits, ordDigits: int; sigAll, ordAll, expForm, sigSign, ordSign: boolean);
var
idx: int;
maxValue: long;
begin
inherited create();
if sigDigits < MIN_SIGNIFICAND_DIGITS then sigDigits := MIN_SIGNIFICAND_DIGITS;
if sigDigits > MAX_SIGNIFICAND_DIGITS then sigDigits := MAX_SIGNIFICAND_DIGITS;
if ordDigits < MIN_ORDER_DIGITS then ordDigits := MIN_ORDER_DIGITS;
if ordDigits > MAX_ORDER_DIGITS then ordDigits := MAX_ORDER_DIGITS;
maxValue := 1;
for idx := sigDigits - 2 downto 0 do maxValue := maxValue * 10;
fldSigAll := sigAll;
fldOrdAll := ordAll;
fldSigSign := sigSign;
fldOrdSign := ordSign;
fldExpForm := expForm;
fldSigDigits := sigDigits;
fldOrdDigits := ordDigits;
fldMinRepresentValue := maxValue;
fldMaxRepresentValue := maxValue * 10 - 1;
fldLimitValueWithFractialPart := pow10(1, sigDigits - 1);
fldLimitValueWithoutExponent := pow10(1, sigDigits);
end;
function RealRepresenter.equals(anot: TObject): boolean;
var
repr: RealRepresenter;
begin
if anot = self then begin
result := true;
exit;
end;
if not(anot is RealRepresenter) then begin
result := false;
exit;
end;
repr := RealRepresenter(anot);
result :=
(repr.fldSigAll = fldSigAll) and
(repr.fldOrdAll = fldOrdAll) and
(repr.fldSigSign = fldSigSign) and
(repr.fldOrdSign = fldOrdSign) and
(repr.fldExpForm = fldExpForm) and
(repr.fldSigDigits = fldSigDigits) and
(repr.fldOrdDigits = fldOrdDigits)
;
end;
function RealRepresenter.getHashCode(): long;
begin
result := 0;
if fldSigAll then inc(result, $01);
if fldOrdAll then inc(result, $02);
if fldSigSign then inc(result, $04);
if fldOrdSign then inc(result, $08);
if fldExpForm then inc(result, $10);
inc(result, ((fldSigDigits - MIN_SIGNIFICAND_DIGITS) shl 8) + ((fldOrdDigits - MIN_ORDER_DIGITS) shl 16));
end;
function RealRepresenter.writeTo(const dst: char_Array1d; offset: int; value: real): int;
var
length: int;
repr: char_Array1d;
begin
repr := toCharArray(value);
length := system.length(repr);
&Array.copyPrimitives(repr, 0, dst, offset, length);
result := offset + length;
end;
function RealRepresenter.parseFloat(const str: AnsiString): float;
var
value: real;
begin
if (str = '+Infinity') or (str = 'Infinity') then begin
result := CoFloat.POSITIVE_INFINITY;
exit;
end;
if (str = '-Infinity') then begin
result := CoFloat.NEGATIVE_INFINITY;
exit;
end;
if (str = 'NaN') then begin
result := CoFloat.NAN;
exit;
end;
value := parse(str);
if (value < -CoFloat.MAX_VALUE) or (value > CoFloat.MAX_VALUE) then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
result := CoReal.toFloat(value);
end;
function RealRepresenter.parseDouble(const str: AnsiString): double;
var
value: real;
begin
if (str = '+Infinity') or (str = 'Infinity') then begin
result := CoDouble.POSITIVE_INFINITY;
exit;
end;
if (str = '-Infinity') then begin
result := CoDouble.NEGATIVE_INFINITY;
exit;
end;
if (str = 'NaN') then begin
result := CoDouble.NAN;
exit;
end;
value := parse(str);
if (value < -CoDouble.MAX_VALUE) or (value > CoDouble.MAX_VALUE) then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
result := CoReal.toDouble(value);
end;
function RealRepresenter.parseReal(const str: AnsiString): real;
var
value: real;
begin
if (str = '+Infinity') or (str = 'Infinity') then begin
result := CoReal.POSITIVE_INFINITY;
exit;
end;
if (str = '-Infinity') then begin
result := CoReal.NEGATIVE_INFINITY;
exit;
end;
if (str = 'NaN') then begin
result := CoReal.NAN;
exit;
end;
value := parse(str);
if (value < -CoReal.MAX_VALUE) or (value > CoReal.MAX_VALUE) then begin
raise NumberFormatException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument.number-format'));
end;
result := value;
end;
function RealRepresenter.toString(value: real): AnsiString;
begin
if CoReal.isNaN(value) then begin
result := 'NaN';
exit;
end;
if value = CoReal.POSITIVE_INFINITY then begin
result := 'Infinity';
exit;
end;
if value = CoReal.NEGATIVE_INFINITY then begin
result := '-Infinity';
exit;
end;
result := AnsiString.create(represent(value));
end;
function RealRepresenter.toCharArray(value: real): char_Array1d;
begin
if CoReal.isNaN(value) then begin
result := AnsiString('NaN').toCharArray();
exit;
end;
if value = CoReal.POSITIVE_INFINITY then begin
result := AnsiString('Infinity').toCharArray();
exit;
end;
if value = CoReal.NEGATIVE_INFINITY then begin
result := AnsiString('-Infinity').toCharArray();
exit;
end;
result := represent(value);
end;
{%endregion}
{%region Mutex}
constructor Mutex.create();
begin
inherited create();
mutexCreate(@fldMutex);
end;
destructor Mutex.destroy;
begin
mutexDestroy(@fldMutex);
inherited destroy;
end;
procedure Mutex.beginSynchronized();
begin
mutexLock(@fldMutex);
end;
procedure Mutex.endSynchronized();
begin
mutexUnlock(@fldMutex);
end;
function Mutex.isHold(): boolean;
begin
result := mutexIsHold(@fldMutex);
end;
{%endregion}
{%region Monitor}
class function Monitor.newThreadStateEntryArray1d(length: int): ThreadStateEntry_Array1d;
begin
result := nil;
setLength(result, length);
end;
procedure Monitor.resume(const entry: ThreadStateEntry; needSignal: boolean);
begin
with fldOwnedBy do begin
state := OWNEDBY;
threadId := entry.threadId;
lockCount := entry.lockCount;
if needSignal then eventSetSignalled(threadGetEvent(threadId));
end;
end;
procedure Monitor.extractEntry();
var
index: int;
length: int;
entries: ThreadStateEntry_Array1d;
entry: ThreadStateEntry;
label
break_label0;
begin
entries := fldEntries;
if entries = nil then with fldOwnedBy do begin
state := 0;
threadId := 0;
lockCount := 0;
exit;
end;
length := fldLength;
begin
for index := 0 to length - 1 do with entries[index] do if state = BLOCKED then begin
entry.threadId := threadId;
entry.lockCount := lockCount;
goto break_label0;
end;
with fldOwnedBy do begin
state := 0;
threadId := 0;
lockCount := 0;
exit;
end;
end;
break_label0:
dec(length);
&Array.copyRaw(entries[index + 1], entries[index], (length - index) * sizeof(ThreadStateEntry));
with entries[length] do begin
state := 0;
threadId := 0;
lockCount := 0;
end;
fldLength := length;
resume(entry, true);
end;
procedure Monitor.extractEntry(threadId: long);
var
index: int;
length: int;
threadIdArgument: long absolute threadId;
entries: ThreadStateEntry_Array1d;
entry: ThreadStateEntry;
label
break_label0;
begin
entries := fldEntries;
if entries = nil then with fldOwnedBy do begin
state := 0;
threadId := 0;
lockCount := 0;
exit;
end;
length := fldLength;
begin
for index := 0 to length - 1 do with entries[index] do if threadId = threadIdArgument then begin
entry.threadId := threadId;
entry.lockCount := lockCount;
goto break_label0;
end;
with fldOwnedBy do begin
state := 0;
threadId := 0;
lockCount := 0;
exit;
end;
end;
break_label0:
dec(length);
&Array.copyRaw(entries[index + 1], entries[index], (length - index) * sizeof(ThreadStateEntry));
with entries[length] do begin
state := 0;
threadId := 0;
lockCount := 0;
end;
fldLength := length;
resume(entry, false);
end;
procedure Monitor.appendEntry(const entry: ThreadStateEntry);
var
length: int;
entriesData: ThreadStateEntry_Array1d;
entriesCopy: ThreadStateEntry_Array1d;
begin
entriesData := fldEntries;
if entriesData = nil then begin
entriesData := newThreadStateEntryArray1d($0f);
fldEntries := entriesData;
with entriesData[0] do begin
state := entry.state;
threadId := entry.threadId;
lockCount := entry.lockCount;
end;
fldLength := 1;
exit;
end;
length := fldLength;
if length = system.length(entriesData) then begin
entriesCopy := newThreadStateEntryArray1d((length shl 1) or 1);
&Array.copyRaw(entriesData[0], entriesCopy[0], length * sizeof(ThreadStateEntry));
entriesData := entriesCopy;
fldEntries := entriesData;
end;
with entriesData[length] do begin
state := entry.state;
threadId := entry.threadId;
lockCount := entry.lockCount;
end;
fldLength := length + 1;
end;
function Monitor.getEntryIndexByState(state: long): int;
var
index: int;
length: int;
entries: ThreadStateEntry_Array1d;
label
break_label0;
begin
entries := fldEntries;
if entries = nil then begin
result := -1;
exit;
end;
length := fldLength;
begin
for index := 0 to length - 1 do if entries[index].state = state then goto break_label0;
result := -1;
exit;
end;
break_label0:
result := index;
end;
function Monitor.getEntryIndexByThreadId(threadId: long): int;
var
index: int;
length: int;
entries: ThreadStateEntry_Array1d;
label
break_label0;
begin
entries := fldEntries;
if entries = nil then begin
result := -1;
exit;
end;
length := fldLength;
begin
for index := 0 to length - 1 do if entries[index].threadId = threadId then goto break_label0;
result := -1;
exit;
end;
break_label0:
result := index;
end;
procedure Monitor.beginSynchronized();
var
isBlocked: boolean;
currentId: long;
entry: ThreadStateEntry;
begin
isBlocked := false;
currentId := threadGetCurrentId();
inherited beginSynchronized();
try
with fldOwnedBy do begin
entry.state := state;
entry.threadId := threadId;
entry.lockCount := lockCount;
end;
if entry.state = 0 then with fldOwnedBy do begin
state := OWNEDBY;
threadId := currentId;
lockCount := 1;
end else
if entry.threadId = currentId then with fldOwnedBy do begin
lockCount := entry.lockCount + 1;
end else begin
entry.state := BLOCKED;
entry.threadId := currentId;
entry.lockCount := 1;
appendEntry(entry);
isBlocked := true;
end;
finally
inherited endSynchronized();
end;
if isBlocked then begin
eventWaitSignalled(threadGetEvent(currentId), 0, 0);
end;
end;
procedure Monitor.endSynchronized();
var
isNotOwnedBy: boolean;
currentId: long;
entry: ThreadStateEntry;
begin
isNotOwnedBy := false;
currentId := threadGetCurrentId();
inherited beginSynchronized();
try
with fldOwnedBy do begin
entry.state := state;
entry.threadId := threadId;
entry.lockCount := lockCount;
end;
if (entry.state = 0) or (entry.threadId <> currentId) then begin
isNotOwnedBy := true;
end else
with fldOwnedBy do begin
lockCount := entry.lockCount - 1;
if lockCount = 0 then extractEntry();
end;
finally
inherited endSynchronized();
end;
if isNotOwnedBy then begin
raise IllegalMonitorStateException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-state.monitor'));
end;
end;
procedure Monitor.notify();
var
isNotOwnedBy: boolean;
index: int;
currentId: long;
entry: ThreadStateEntry;
begin
isNotOwnedBy := false;
currentId := threadGetCurrentId();
inherited beginSynchronized();
try
with fldOwnedBy do begin
entry.state := state;
entry.threadId := threadId;
end;
if (entry.state = 0) or (entry.threadId <> currentId) then begin
isNotOwnedBy := true;
end else begin
index := getEntryIndexByState(WAITING);
if index < 0 then begin
inc(fldNotifies);
end else begin
fldEntries[index].state := BLOCKED;
end;
end;
finally
inherited endSynchronized();
end;
if isNotOwnedBy then begin
raise IllegalMonitorStateException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-state.monitor'));
end;
end;
procedure Monitor.notifyAll();
var
isNotOwnedBy: boolean;
isNotBlocked: boolean;
index: int;
currentId: long;
entries: ThreadStateEntry_Array1d;
entry: ThreadStateEntry;
begin
isNotOwnedBy := false;
currentId := threadGetCurrentId();
inherited beginSynchronized();
try
with fldOwnedBy do begin
entry.state := state;
entry.threadId := threadId;
end;
if (entry.state = 0) or (entry.threadId <> currentId) then begin
isNotOwnedBy := true;
end else begin
entries := fldEntries;
isNotBlocked := true;
for index := fldLength - 1 downto 0 do with entries[index] do if state <> BLOCKED then begin
isNotBlocked := false;
state := BLOCKED;
end;
if isNotBlocked then begin
inc(fldNotifies);
end;
end;
finally
inherited endSynchronized();
end;
if isNotOwnedBy then begin
raise IllegalMonitorStateException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-state.monitor'));
end;
end;
procedure Monitor.wait();
begin
wait(0, 0);
end;
procedure Monitor.wait(timeInMillis: long);
begin
wait(timeInMillis, 0);
end;
procedure Monitor.wait(timeInMillis: long; timeInNanos: int);
var
isWaiting: boolean;
isNotOwnedBy: boolean;
index: int;
currentId: long;
notifies: long;
event: long;
entry: ThreadStateEntry;
begin
if timeInMillis < 0 then begin
raise IllegalArgumentException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument'), [ CoAnsiString.create('timeInMillis') ]));
end;
if (timeInNanos < 0) or (timeInNanos > 999999) then begin
raise IllegalArgumentException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument'), [ CoAnsiString.create('timeInNanos') ]));
end;
isWaiting := false;
isNotOwnedBy := false;
currentId := threadGetCurrentId();
inherited beginSynchronized();
try
with fldOwnedBy do begin
entry.state := state;
entry.threadId := threadId;
entry.lockCount := lockCount;
end;
if (entry.state = 0) or (entry.threadId <> currentId) then begin
isNotOwnedBy := true;
end else begin
notifies := fldNotifies;
if notifies <> 0 then begin
fldNotifies := notifies - 1;
end else begin
extractEntry();
entry.state := WAITING;
appendEntry(entry);
isWaiting := true;
end;
end;
finally
inherited endSynchronized();
end;
if isNotOwnedBy then begin
raise IllegalMonitorStateException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-state.monitor'));
end;
if isWaiting then begin
event := threadGetEvent(currentId);
eventWaitSignalled(event, timeInMillis, timeInNanos);
repeat
inherited beginSynchronized();
try
with fldOwnedBy do begin
entry.state := state;
entry.threadId := threadId;
end;
if entry.state = 0 then begin
extractEntry(currentId);
isWaiting := false;
end else
if entry.threadId = currentId then begin
isWaiting := false;
end else begin
index := getEntryIndexByThreadId(currentId);
fldEntries[index].state := BLOCKED;
end;
finally
inherited endSynchronized();
end;
if not isWaiting then break;
eventWaitSignalled(event, 0, 0);
until false;
end;
end;
function Monitor.isHold(): boolean;
begin
result := fldOwnedBy.state <> 0;
end;
{%endregion}
{%region Thread}
class procedure Thread.yield();
begin
threadSleep(0, 0);
end;
class procedure Thread.sleep(timeInMillis: long);
begin
if timeInMillis < 0 then begin
raise IllegalArgumentException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument'), [ CoAnsiString.create('timeInMillis') ]));
end;
threadSleep(timeInMillis, 0);
end;
class procedure Thread.sleep(timeInMillis: long; timeInNanos: int);
begin
if timeInMillis < 0 then begin
raise IllegalArgumentException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument'), [ CoAnsiString.create('timeInMillis') ]));
end;
if (timeInNanos < 0) or (timeInNanos > 999999) then begin
raise IllegalArgumentException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument'), [ CoAnsiString.create('timeInNanos') ]));
end;
threadSleep(timeInMillis, timeInNanos);
end;
class function Thread.activeCount(): int;
begin
result := threadGetActiveCount();
end;
{$IFNDEF LIBRARY}
class function Thread.enumerate(): Thread_Collection1d;
var
idx: int;
len: int;
threadIds: long_Array1d;
threadRefs: Thread_Array1d;
begin
threadIds := threadEnumerateIds1();
len := length(threadIds);
threadRefs := Thread_Array1d(&Array.newTObject1d(len));
for idx := len - 1 downto 0 do begin
threadRefs[idx] := threadGet(threadIds[idx], true);
end;
result := ThreadCollection.create(threadRefs);
end;
{$ENDIF}
class function Thread.current(): Thread;
begin
result := threadGet(threadGetCurrentId());
end;
constructor Thread.create(threadId1, threadId2: long; external: boolean);
var
flags: byte;
begin
inherited create();
flags := FLAG_AUTO_FREE;
if external then inc(flags, FLAG_EXTERNAL);
if threadId2 = -2 then threadId2 := threadId1;
fldStarted := true;
fldCreated := false;
fldTerminated := false;
fldFlags := flags;
fldPriority := threadGetPriority(threadId2);
fldStackSize := 0;
fldThreadId1 := threadId1;
fldThreadId2 := threadId2;
fldEnumerated := 0;
fldDescription := threadGetDescription(threadId2);
fldTarget := nil;
fldJoinMonitor := nil;
end;
procedure Thread.notifyJoined();
begin
with fldJoinMonitor do begin
beginSynchronized();
try
fldTerminated := true;
notifyAll();
finally
endSynchronized();
end;
end;
end;
procedure Thread.freeIfNecessary();
begin
if (self <> nil) and (fldEnumerated = 0) and (fldFlags <> 0) then destroy;
end;
procedure Thread.setDescription(const newDescription: AnsiString);
begin
if getFlag(FLAG_EXTERNAL) then exit;
fldDescription := newDescription;
threadSetDescription(fldThreadId2, newDescription);
end;
function Thread.isStarted(): boolean; assembler; nostackframe;
asm
mov eax, true
{$IFDEF WINDOWS}
xchg byte [rcx+offset fldStarted], al
{$ELSE}
xchg byte [rdi+offset fldStarted], al
{$ENDIF}
movzx eax, al
end;
function Thread.getFlag(mask: int): boolean;
begin
result := (fldFlags and mask) <> 0;
end;
function Thread.getPriority(): int;
var
locPriority: int;
begin
locPriority := threadGetPriority(fldThreadId2);
if locPriority = UD_PRIORITY then locPriority := fldPriority;
result := locPriority;
end;
function Thread.getDescription(): AnsiString;
var
locDescription: AnsiString;
begin
locDescription := threadGetDescription(fldThreadId2);
if locDescription = '' then locDescription := fldDescription;
result := locDescription;
end;
constructor Thread.create(stackSize: long; freeOnTerminate: boolean);
begin
create(nil, stackSize, freeOnTerminate);
end;
procedure Thread.setPriority(newPriority: int);
begin
if getFlag(FLAG_EXTERNAL) then exit;
if newPriority < MIN_PRIORITY then newPriority := MIN_PRIORITY;
if newPriority > MAX_PRIORITY then newPriority := MAX_PRIORITY;
fldPriority := newPriority;
threadSetPriority(fldThreadId2, newPriority);
end;
constructor Thread.create(target: Runnable; freeOnTerminate: boolean);
begin
create(target, DEFAULT_STACK_SIZE, freeOnTerminate);
end;
constructor Thread.create(target: Runnable; stackSize: long; freeOnTerminate: boolean);
var
flags: byte;
begin
inherited create();
flags := 0;
if freeOnTerminate then inc(flags, FLAG_AUTO_FREE);
if stackSize < MIN_STACK_SIZE then stackSize := MIN_STACK_SIZE;
if stackSize > MAX_STACK_SIZE then stackSize := MAX_STACK_SIZE;
fldStarted := false;
fldCreated := false;
fldTerminated := false;
fldFlags := flags;
fldPriority := NORM_PRIORITY;
fldStackSize := stackSize;
fldThreadId1 := -1;
fldThreadId2 := -1;
fldEnumerated := 0;
fldDescription := '';
fldTarget := target;
fldJoinMonitor := nil;
end;
destructor Thread.destroy;
begin
fldJoinMonitor.free();
inherited destroy;
end;
procedure Thread.run();
begin
end;
procedure Thread.start();
begin
if isStarted() then begin
raise IllegalThreadStateException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-state.thread'));
end;
fldJoinMonitor := Monitor.create();
if not threadCreate(@threadFunction, self, fldStackSize) then begin
raise errorOutOfMemory;
end;
fldCreated := true;
end;
procedure Thread.join();
var
jmon: Monitor;
begin
jmon := fldJoinMonitor;
if jmon = nil then begin
raise IllegalThreadStateException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-state.thread'));
end;
with jmon do begin
beginSynchronized();
try
if not fldTerminated then wait(0, 0);
finally
endSynchronized();
end;
end;
end;
procedure Thread.join(timeInMillis: long);
var
jmon: Monitor;
begin
if timeInMillis < 0 then begin
raise IllegalArgumentException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument'), [ CoAnsiString.create('timeInMillis') ]));
end;
jmon := fldJoinMonitor;
if jmon = nil then begin
raise IllegalThreadStateException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-state.thread'));
end;
with jmon do begin
beginSynchronized();
try
if not fldTerminated then wait(timeInMillis, 0);
finally
endSynchronized();
end;
end;
end;
procedure Thread.join(timeInMillis: long; timeInNanos: int);
var
jmon: Monitor;
begin
if timeInMillis < 0 then begin
raise IllegalArgumentException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument'), [ CoAnsiString.create('timeInMillis') ]));
end;
if (timeInNanos < 0) or (timeInNanos > 999999) then begin
raise IllegalArgumentException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-argument'), [ CoAnsiString.create('timeInNanos') ]));
end;
jmon := fldJoinMonitor;
if jmon = nil then begin
raise IllegalThreadStateException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'illegal-state.thread'));
end;
with jmon do begin
beginSynchronized();
try
if not fldTerminated then wait(timeInMillis, timeInNanos);
finally
endSynchronized();
end;
end;
end;
function Thread._addref(): int; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
begin
result := -1;
end;
function Thread._release(): int; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
begin
result := -1;
end;
function Thread.isAlive(): boolean;
begin
result := fldCreated or threadIsAlive(fldThreadId1, fldThreadId2);
end;
function Thread.isExternal(): boolean;
begin
result := getFlag(FLAG_EXTERNAL);
end;
{%endregion}
{%region Throwable}
constructor Throwable.create(const message: AnsiString; helpContext: int);
var
count: int;
length: int;
buffer: Pointer_Array1d;
stackTrace: Pointer_Array1d;
begin
inherited create();
if self is Error then begin
stackTrace := nil;
end else begin
length := $1f;
stackTrace := &Array.newPointer1d(length);
repeat
count := int(system.captureBackTrace(1, length, Pointer(stackTrace)));
if count < length then begin
buffer := &Array.newPointer1d(count);
&Array.copyRaw(stackTrace[0], buffer[0], long(count) * sizeof(Pointer));
stackTrace := buffer;
break;
end;
if count = CoInt.MAX_VALUE then break;
length := (length shl 1) or 1;
stackTrace := &Array.newPointer1d(length);
until false;
end;
fldMessage := message;
fldHelpContext := helpContext;
fldStackTrace := stackTrace;
end;
procedure Throwable.printStackTrace();
var
index: int;
infol: int;
infoa: AnsiString;
infos: ShortString;
stackTrace: Pointer_Array1d;
element: Pointer;
begin
if isConsole then begin
writeln(system.errOutput, toString(){$IFDEF WINDOWS}.toUTF16(){$ENDIF});
stackTrace := fldStackTrace;
for index := 0 to system.length(stackTrace) - 1 do begin
element := stackTrace[index];
if element <> nil then begin
infos := system.backTraceStrFunc(element);
infol := system.length(infos);
infoa := AnsiString.create(infol);
&Array.copyRaw(infos[1], infoa[1], long(infol) * sizeof(char));
writeln(system.errOutput, infoa{$IFDEF WINDOWS}.toUTF16(){$ENDIF});
end;
end;
end;
end;
function Throwable.toString(): AnsiString;
var
locMessage: AnsiString;
begin
locMessage := fldMessage;
if locMessage.length <= 0 then begin
result := getClass().getCanonicalName();
exit;
end;
result := getClass().getCanonicalName() + ': ' + locMessage;
end;
function Throwable.clone(): Throwable;
var
copy: Throwable;
begin
copy := Throwable(classType().create());
copy.fldHelpContext := fldHelpContext;
copy.fldMessage := fldMessage;
copy.fldStackTrace := fldStackTrace;
result := copy;
end;
{%endregion}
{%region MemoryError}
procedure MemoryError.freeAllow();
begin
fldFreeDisallowed := false;
end;
procedure MemoryError.freeDisallow();
begin
fldFreeDisallowed := true;
end;
procedure MemoryError.freeInstance();
begin
if not fldFreeDisallowed then begin
inherited freeInstance();
end;
end;
{%endregion}
{%region AResource }
class procedure AResource.updateResourceStringReferences();
var
index: long;
address: Pointer;
rlist: PResourceStringInitEntry;
begin
with resourcestringInits^ do for index := 0 to length - 1 do begin
rlist := list[index];
address := rlist^.address;
while address <> nil do begin
AnsiString(address^) := rlist^.data^.value;
inc(rlist);
address := rlist^.address;
end;
end;
end;
class procedure AResource.setResourceString(const __unitName, rstrName, rstrValue: AnsiString);
var
index: long;
unitUpper: AnsiString;
rstrLower: AnsiString;
rfinish: PResourceStringStruct;
rstring: PResourceStringStruct;
begin
unitUpper := __unitName.toUpperCase();
rstrLower := (__unitName + '.' + rstrName).toLowerCase();
with resourcestringTables^ do for index := 0 to length - 1 do with list[index] do begin
rstring := start^;
if rstring^.name = unitUpper then begin
inc(rstring);
rfinish := finish^;
while rstring < rfinish do begin
if rstring^.name = rstrLower then begin
rstring^.value := rstrValue;
break;
end;
inc(rstring);
end;
break;
end;
end;
updateResourceStringReferences();
end;
class function AResource.getResourceString(const __unitName, rstrName: AnsiString): AnsiString;
var
index: long;
unitUpper: AnsiString;
rstrLower: AnsiString;
rfinish: PResourceStringStruct;
rstring: PResourceStringStruct;
begin
unitUpper := __unitName.toUpperCase();
rstrLower := (__unitName + '.' + rstrName).toLowerCase();
with resourcestringTables^ do for index := 0 to length - 1 do with list[index] do begin
rstring := start^;
if rstring^.name = unitUpper then begin
inc(rstring);
rfinish := finish^;
while rstring < rfinish do begin
if rstring^.name = rstrLower then begin
result := rstring^.value;
exit;
end;
inc(rstring);
end;
break;
end;
end;
result := '';
end;
class function AResource.unitToResourceName(const __unitName, rsrcName: AnsiString): AnsiString;
begin
if __unitName.length <= 0 then begin
result := ('/' + rsrcName).toUpperCase();
exit;
end;
result := ('/' + __unitName.replaceAll('.', '/') + '/' + rsrcName).toUpperCase();
end;
class function AResource.unitToTextResourceName(const __unitName, rsrcName: AnsiString): AnsiString;
begin
if __unitName.length <= 0 then begin
result := ('/' + rsrcName + '.TXT').toUpperCase();
exit;
end;
result := ('/' + __unitName.replaceAll('.', '/') + '/' + rsrcName + '.TXT').toUpperCase();
end;
class function AResource.readResourceAsAnsiString(const rsrcName: AnsiString): AnsiString;
var
size: int;
inst: long;
desc: long;
handle: long;
rstring: AnsiString;
data: Pointer;
begin
inst := system.hInstance();
desc := long(system.findResource(inst, rsrcName, system.PAnsiChar({$IFDEF WINDOWS}windows{$ELSE}system{$ENDIF}.RT_RCDATA)));
if desc = 0 then begin
result := '';
exit;
end;
handle := long(system.loadResource(inst, desc));
if handle = 0 then begin
result := '';
exit;
end;
size := int(system.sizeofResource(inst, desc));
data := system.lockResource(handle);
try
rstring := AnsiString.create(size);
&Array.copyRaw(data^, rstring[1], size);
result := rstring;
finally
system.unlockResource(handle);
system.freeResource(handle);
end;
end;
class function AResource.readUnitResourceAsAnsiString(const __unitName, rstrName: AnsiString): AnsiString;
begin
result := readResourceAsAnsiString(unitToTextResourceName(__unitName, rstrName));
end;
{%endregion}
{%region Lang}
class function Lang.getGuidIndex(const guid: system.TGuid; capacity: int): int;
var
gvec: long2 absolute guid;
begin
result := int(((gvec[0] xor gvec[1]) and CoLong.MAX_VALUE) mod capacity);
end;
class procedure Lang.registerInterfaces(const iinfos: array of Pointer);
var
idx: int;
len: int;
oldIdx: int;
oldLen: int;
oldCap: int;
newIdx: int;
newLen: int;
newCap: int;
iinfop: PTypeInfo;
idatap: PTypeData;
iguidp: system.PGuid;
oldEntry: InterfaceEntry;
newEntry: InterfaceEntry;
oldTable: InterfaceEntry_Array1d;
newTable: InterfaceEntry_Array1d;
begin
len := length(iinfos);
if len <= 0 then exit;
oldTable := registeredInterfacesEntries;
oldLen := registeredInterfacesLength;
oldCap := length(oldTable);
newLen := oldLen + len;
if newLen < 0 then begin
raise BufferTooLargeError.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, '!error.buffer-too-large'));
end;
newCap := oldCap;
if newLen > ((newCap shl 1) or 1) then begin
repeat
newCap := (newCap shl 1) or 1;
until newLen <= ((newCap shl 1) or 1);
newTable := InterfaceEntry_Array1d(&Array.newTObject1d(newCap));
for oldIdx := oldCap - 1 downto 0 do begin
oldEntry := oldTable[oldIdx];
while oldEntry <> nil do begin
newIdx := getGuidIndex(oldEntry.guid, newCap);
newEntry := oldEntry;
oldEntry := oldEntry.next;
newEntry.next := newTable[newIdx];
newTable[newIdx] := newEntry;
end;
end;
oldCap := newCap;
oldTable := newTable;
registeredInterfacesEntries := newTable;
end;
for idx := 0 to len - 1 do begin
iinfop := PTypeInfo(iinfos[idx]);
idatap := getTypeData(iinfop);
iguidp := @(idatap^.guid);
oldIdx := getGuidIndex(iguidp^, oldCap);
oldTable[oldIdx] := InterfaceEntry.create(iguidp^, iinfop, oldTable[oldIdx]);
end;
registeredInterfacesLength := newLen;
end;
class function Lang.isType(const typRef, typIID: ShortString): boolean;
var
len: int;
begin
len := length(typIID);
result := (len > 0) and (length(typRef) = len) and (&Array.compfne(typRef[1], typIID[1], 0, len) = &Array.NOT_FOUND);
end;
class function Lang.isType(const typRef, typIID: system.TGuid): boolean;
begin
result := &Array.compfne(typRef, typIID, 3, 2) = &Array.NOT_FOUND;
end;
class function Lang.isInstance(objRef: ISimple; const typIID: ShortString): boolean;
var
tmpIID: system.TGuid;
tmpRef: Pointer;
begin
result := guidTryParse(typIID, tmpIID) and (objRef <> nil) and (objRef.queryInterface(tmpIID, tmpRef) = system.S_OK);
end;
class function Lang.isInstance(objRef: ISimple; const typIID: system.TGuid): boolean;
var
tmpRef: TObject;
begin
result := (objRef <> nil) and (objRef.queryInterface(IObjectInstance, tmpRef) = system.S_OK) and (tmpRef.getInterfaceEntry(typIID) <> nil);
end;
class function Lang.isInstance(objRef: ISimple; const typRef: system.TClass): boolean;
var
tmpRef: TObject;
begin
result := (objRef <> nil) and (objRef.queryInterface(IObjectInstance, tmpRef) = system.S_OK) and tmpRef.inheritsFrom(typRef);
end;
class function Lang.isInstance(objRef: IUnknown; const typIID: ShortString): boolean;
var
tmpIID: system.TGuid;
tmpRef: Pointer;
begin
result := guidTryParse(typIID, tmpIID) and (objRef <> nil) and (objRef.queryInterface(tmpIID, tmpRef) = system.S_OK);
end;
class function Lang.identityHashCode(objRef: TObject): long;
begin
result := long(objRef);
end;
class function Lang.identityHashCode(objRef: ISimple): long;
var
tmpRef: long;
begin
tmpRef := 0;
if (objRef <> nil) and (objRef.queryInterface(IObjectInstance, tmpRef) <> system.S_OK) then begin
result := 0;
exit;
end;
result := tmpRef;
end;
class function Lang.identityHashCode(objRef: IUnknown): long;
var
tmpRef: long;
begin
tmpRef := 0;
if (objRef <> nil) and (objRef.queryInterface(IObjectInstance, tmpRef) <> system.S_OK) then begin
result := 0;
exit;
end;
result := tmpRef;
end;
class function Lang.cast(objRef: ISimple; const typIID: ShortString): ISimple;
var
tmpIID: system.TGuid;
tmpRef: Pointer;
begin
if not guidTryParse(typIID, tmpIID) then begin
system.runError(219);
end;
if objRef = nil then begin
result := nil;
exit;
end;
if objRef.queryInterface(tmpIID, tmpRef) <> system.S_OK then begin
system.runError(219);
end;
result := nil;
Pointer(result) := tmpRef;
end;
class function Lang.cast(objRef: ISimple; const typIID: system.TGuid): IUnknown;
var
tmpRef: Pointer;
begin
if objRef = nil then begin
result := nil;
exit;
end;
if objRef.queryInterface(typIID, tmpRef) <> system.S_OK then begin
system.runError(219);
end;
result := nil;
Pointer(result) := tmpRef;
end;
class function Lang.cast(objRef: ISimple; const typRef: system.TClass): TObject;
var
tmpRef: TObject;
begin
if typRef = nil then begin
system.runError(219);
end;
if objRef = nil then begin
result := nil;
exit;
end;
if (objRef.queryInterface(IObjectInstance, tmpRef) <> System.S_OK) or not tmpRef.inheritsFrom(typRef) then begin
system.runError(219);
end;
result := nil;
Pointer(result) := tmpRef;
end;
class function Lang.cast(objRef: IUnknown; const typIID: ShortString): ISimple;
var
tmpIID: system.TGuid;
tmpRef: Pointer;
begin
if not guidTryParse(typIID, tmpIID) then begin
system.runError(219);
end;
if objRef = nil then begin
result := nil;
exit;
end;
if objRef.queryInterface(tmpIID, tmpRef) <> system.S_OK then begin
system.runError(219);
end;
result := nil;
Pointer(result) := tmpRef;
end;
class function Lang.classFor(const typIID: ShortString): &Class;
var
idx: int;
entry: InterfaceEntry;
tmpIID: system.TGuid;
begin
if not guidTryParse(typIID, tmpIID) then begin
result := nil;
exit;
end;
idx := getGuidIndex(tmpIID, length(registeredInterfacesEntries));
entry := registeredInterfacesEntries[idx];
while entry <> nil do begin
if &Array.compfne(entry.guid, tmpIID, 3, 2) = &Array.NOT_FOUND then begin
result := InterfaceTypeInformation.create(entry.info);
exit;
end;
entry := entry.next;
end;
result := InterfaceTypeInformation.create(PTypeInfo(typeInfo(ISimple)));
end;
class function Lang.classFor(const typIID: system.TGuid): &Class;
var
idx: int;
entry: InterfaceEntry;
begin
idx := getGuidIndex(typIID, length(registeredInterfacesEntries));
entry := registeredInterfacesEntries[idx];
while entry <> nil do begin
if &Array.compfne(entry.guid, typIID, 3, 2) = &Array.NOT_FOUND then begin
result := InterfaceTypeInformation.create(entry.info);
exit;
end;
entry := entry.next;
end;
result := InterfaceTypeInformation.create(PTypeInfo(typeInfo(IUnknown)));
end;
class function Lang.classFor(const typRef: system.TClass): &Class;
begin
if typRef = nil then begin
result := nil;
exit;
end;
result := ClassTypeInformation.create(typRef);
end;
class function Lang.classFor(tinfo: Pointer): &Class;
var
subTypeKind: int;
argTypeKind: int;
argTypeInfo: PTypeInfo absolute tinfo;
typeInstance: &Class;
begin
if tinfo = nil then begin
result := nil;
exit;
end;
{$IFDEF WINDOWS}
if tinfo = typeInfo(real) then begin
result := primitives[TYPE_REAL];
exit;
end;
{$ENDIF}
argTypeKind := int(argTypeInfo^.kind);
case TTypeKind(argTypeKind) of
tkInteger, tkInt64, tkQWord: begin
subTypeKind := int(getTypeData(argTypeInfo)^.ordType);
typeInstance := primitives[subTypeKind + 30];
if typeInstance = nil then begin
typeInstance := primitives[argTypeKind];
end;
result := typeInstance;
end;
tkFloat: begin
subTypeKind := int(getTypeData(argTypeInfo)^.floatType);
typeInstance := primitives[subTypeKind + 38];
if typeInstance = nil then begin
typeInstance := primitives[argTypeKind];
end;
result := typeInstance;
end;
tkChar, tkSString, tkAString, tkWString, tkWChar, tkBool, tkUString, tkPointer: begin
result := primitives[argTypeKind];
end;
tkEnumeration: begin
result := primitives[Lang.TYPE_INT];
end;
tkUChar: begin
result := primitives[Lang.TYPE_UCHAR];
end;
tkClass: begin
result := ClassTypeInformation.create(argTypeInfo);
end;
tkClassRef: begin
result := ClassRefTypeInformation.create(argTypeInfo);
end;
tkInterface, tkInterfaceRaw: begin
result := InterfaceTypeInformation.create(argTypeInfo);
end;
tkDynArray: begin
result := DynamicArrayTypeInformation.create(argTypeInfo);
end;
tkProcVar: begin
result := FunctionTypeInformation.create(argTypeInfo);
end;
else
result := StructuredTypeInformation.create(argTypeInfo);
end;
end;
{%endregion}
{%region Math}
class procedure Math.setRoundMode(mode: int); assembler; nostackframe;
asm
dd $000008c8
fnstcw word [rbp-$08]
and qword [rbp-$08], $0000f3ff
{$IFDEF WINDOWS}
or qword [rbp-$08], rcx
{$ELSE}
or qword [rbp-$08], rdi
{$ENDIF}
fldcw word [rbp-$08]
leave
end;
{$IFDEF WINDOWS}
class function Math.E: real;
begin
result := CoReal.build($4000, $adf85458a2bb4a9b); { e }
end;
class function Math.PI: real;
begin
result := CoReal.build($4000, $c90fdaa22168c235); { π }
end;
class function Math.LOG_2_10: real;
begin
result := CoReal.build($4000, $d49a784bcd1b8afe); { log2(10) }
end;
class function Math.LOG_2_E: real;
begin
result := CoReal.build($3fff, $b8aa3b295c17f0bc); { log2(e) }
end;
class function Math.LOG_10_2: real;
begin
result := CoReal.build($3ffd, $9a209a84fbcff799); { log10(2) }
end;
class function Math.LOG_E_2: real;
begin
result := CoReal.build($3ffe, $b17217f7d1cf79ac); { log(2) }
end;
{$ENDIF}
class function Math.abs(x: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
mov eax, ecx
{$ELSE}
mov eax, edi
{$ENDIF}
test eax, eax
jns @exit
neg eax
@exit:
end;
class function Math.abs(x: long): long; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
mov rax, rcx
{$ELSE}
mov rax, rdi
{$ENDIF}
test rax, rax
jns @exit
neg rax
@exit:
end;
class function Math.abs(x: float): float; assembler; nostackframe;
asm
movdqu xmm1, [rip+int4s-@00+$00]
@00: pand xmm0, xmm1
end;
class function Math.abs(x: double): double; assembler; nostackframe;
asm
movdqu xmm1, [rip+long2s-@00+$00]
@00: pand xmm0, xmm1
end;
class function Math.abs(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
and word [rdx+$08], $7fff
fld tbyte [rdx+$00]
fstp tbyte [rcx+$00]
{$ELSE}
and word [rsp+$10], $7fff
fld tbyte [rsp+$08]
{$ENDIF}
end;
class function Math.sin(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fsin
fnstsw ax
test eax, $00000400
jz @exit
fld tbyte [rip+reals-@00+30] { 2.0 * π }
@00: fxch
@01: fprem
fnstsw ax
test eax, $00000400
jnz @01
fstp st(1)
fsin
@exit:
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.cos(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fcos
fnstsw ax
test eax, $00000400
jz @exit
fld tbyte [rip+reals-@00+30] { 2.0 * π }
@00: fxch
@01: fprem
fnstsw ax
test eax, $00000400
jnz @01
fstp st(1)
fcos
@exit:
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.tan(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fptan
fnstsw ax
test eax, $00000400
jz @exit
fldpi
fxch
@00: fprem
fnstsw ax
test eax, $00000400
jnz @00
fstp st(1)
fptan
@exit: ffree st
fincstp
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.asin(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fld1
fld st(1)
fmul st, st
fsubp st(1), st
fsqrt
fpatan
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.acos(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fld1
fld st(1)
fmul st, st
fsubp st(1), st
fsqrt
fxch
fpatan
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.atan(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fld1
fpatan
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.exp(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fldl2e
fmulp st(1), st
fxam
fnstsw ax
and eax, $00004700
cmp eax, $00000100 { не число }
je @exit
cmp eax, $00000300 { не число }
je @exit
cmp eax, $00000500 { +∞ }
je @exit
cmp eax, $00000700 { –∞ }
jne @00
ffree st
fincstp
fldz
jmp @exit
@00:
{$IFDEF WINDOWS}
lea rdx, [rcx+$00]
mov ecx, ROUND_TOWARD_ZERO
{$ELSE}
mov edi, ROUND_TOWARD_ZERO
{$ENDIF}
call setRoundMode
fld st
fld st
frndint
{$IFDEF WINDOWS}
mov ecx, ROUND_TO_NEAREST
{$ELSE}
mov edi, ROUND_TO_NEAREST
{$ENDIF}
call setRoundMode
{$IFDEF WINDOWS}
lea rcx, [rdx+$00]
{$ENDIF}
fsubp st(1), st
f2xm1
fld1
faddp st(1), st
fscale
fstp st(1)
@exit:
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.exp2(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fxam
fnstsw ax
and eax, $00004700
cmp eax, $00000100 { не число }
je @exit
cmp eax, $00000300 { не число }
je @exit
cmp eax, $00000500 { +∞ }
je @exit
cmp eax, $00000700 { –∞ }
jne @00
ffree st
fincstp
fldz
jmp @exit
@00:
{$IFDEF WINDOWS}
lea rdx, [rcx+$00]
mov ecx, ROUND_TOWARD_ZERO
{$ELSE}
mov edi, ROUND_TOWARD_ZERO
{$ENDIF}
call setRoundMode
fld st
fld st
frndint
{$IFDEF WINDOWS}
mov ecx, ROUND_TO_NEAREST
{$ELSE}
mov edi, ROUND_TO_NEAREST
{$ENDIF}
call setRoundMode
{$IFDEF WINDOWS}
lea rcx, [rdx+$00]
{$ENDIF}
fsubp st(1), st
f2xm1
fld1
faddp st(1), st
fscale
fstp st(1)
@exit:
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.exp10(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fldl2t
fmulp st(1), st
fxam
fnstsw ax
and eax, $00004700
cmp eax, $00000100 { не число }
je @exit
cmp eax, $00000300 { не число }
je @exit
cmp eax, $00000500 { +∞ }
je @exit
cmp eax, $00000700 { –∞ }
jne @00
ffree st
fincstp
fldz
jmp @exit
@00:
{$IFDEF WINDOWS}
lea rdx, [rcx+$00]
mov ecx, ROUND_TOWARD_ZERO
{$ELSE}
mov edi, ROUND_TOWARD_ZERO
{$ENDIF}
call setRoundMode
fld st
fld st
frndint
{$IFDEF WINDOWS}
mov ecx, ROUND_TO_NEAREST
{$ELSE}
mov edi, ROUND_TO_NEAREST
{$ENDIF}
call setRoundMode
{$IFDEF WINDOWS}
lea rcx, [rdx+$00]
{$ENDIF}
fsubp st(1), st
f2xm1
fld1
faddp st(1), st
fscale
fstp st(1)
@exit:
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.log(x: real): real; assembler; nostackframe;
asm
fldln2
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fyl2x
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.log2(x: real): real; assembler; nostackframe;
asm
fld1
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fyl2x
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.log10(x: real): real; assembler; nostackframe;
asm
fldlg2
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fyl2x
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.sqrt(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fsqrt
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.cbrt(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fxam
fnstsw ax
and eax, $00004700
cmp eax, $00000100 { не число }
je @exit
cmp eax, $00000300 { не число }
je @exit
cmp eax, $00004000 { +0 }
je @exit
cmp eax, $00004200 { –0 }
je @exit
cmp eax, $00000500 { +∞ }
je @exit
cmp eax, $00000700 { –∞ }
je @exit
test eax, $00000200
jz @00
fchs
@00: fld tbyte [rip+reals-@01+10] { 1.0 / 3.0 }
@01: fxch
fyl2x
{$IFDEF WINDOWS}
lea rdx, [rcx+$00]
mov ecx, ROUND_TOWARD_ZERO
{$ELSE}
mov edi, ROUND_TOWARD_ZERO
{$ENDIF}
call setRoundMode
fld st
fld st
frndint
{$IFDEF WINDOWS}
mov ecx, ROUND_TO_NEAREST
{$ELSE}
mov edi, ROUND_TO_NEAREST
{$ENDIF}
call setRoundMode
{$IFDEF WINDOWS}
lea rcx, [rdx+$00]
{$ENDIF}
fsubp st(1), st
f2xm1
fld1
faddp st(1), st
fscale
fstp st(1)
test eax, $00000200
jz @exit
fchs
@exit:
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.sinh(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fldl2e
fmulp st(1), st
fxam
fnstsw ax
and eax, $00004700
cmp eax, $00000100 { не число }
je @exit
cmp eax, $00000300 { не число }
je @exit
cmp eax, $00000500 { +∞ }
je @exit
cmp eax, $00000700 { –∞ }
je @exit
{$IFDEF WINDOWS}
lea rdx, [rcx+$00]
mov ecx, ROUND_TOWARD_ZERO
{$ELSE}
mov edi, ROUND_TOWARD_ZERO
{$ENDIF}
call setRoundMode
fld st
fld st
frndint
{$IFDEF WINDOWS}
mov ecx, ROUND_TO_NEAREST
{$ELSE}
mov edi, ROUND_TO_NEAREST
{$ENDIF}
call setRoundMode
{$IFDEF WINDOWS}
lea rcx, [rdx+$00]
{$ENDIF}
fsubp st(1), st
f2xm1
fld1
faddp st(1), st
fscale
fstp st(1)
fld1
fld st(1)
fdivp st(1), st
fsubp st(1), st
fld tbyte [rip+reals-@00+20] { 1.0 / 2.0 }
@00: fmulp st(1), st
@exit:
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.cosh(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fldl2e
fmulp st(1), st
fxam
fnstsw ax
and eax, $00004700
cmp eax, $00000100 { не число }
je @exit
cmp eax, $00000300 { не число }
je @exit
cmp eax, $00000500 { +∞ }
je @exit
cmp eax, $00000700 { –∞ }
jne @00
fchs
jmp @exit
@00:
{$IFDEF WINDOWS}
lea rdx, [rcx+$00]
mov ecx, ROUND_TOWARD_ZERO
{$ELSE}
mov edi, ROUND_TOWARD_ZERO
{$ENDIF}
call setRoundMode
fld st
fld st
frndint
{$IFDEF WINDOWS}
mov ecx, ROUND_TO_NEAREST
{$ELSE}
mov edi, ROUND_TO_NEAREST
{$ENDIF}
call setRoundMode
{$IFDEF WINDOWS}
lea rcx, [rdx+$00]
{$ENDIF}
fsubp st(1), st
f2xm1
fld1
faddp st(1), st
fscale
fstp st(1)
fld1
fld st(1)
fdivp st(1), st
faddp st(1), st
fld tbyte [rip+reals-@01+20] { 1.0 / 2.0 }
@01: fmulp st(1), st
@exit:
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.tanh(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fldl2e
fmulp st(1), st
fxam
fnstsw ax
and eax, $00004700
cmp eax, $00000100 { не число }
je @exit
cmp eax, $00000300 { не число }
je @exit
cmp eax, $00000500 { +∞ }
jne @01
@00: ffree st
fincstp
fld1
jmp @exit
@01: cmp eax, $00000700 { –∞ }
jne @04
@02: ffree st
fincstp
fld tbyte [rip+reals-@03+0] { –1.0 }
@03: jmp @exit
@04: fild dword [rip+ints-@05+$04] { –16384 }
@05: fcomip st, st(1)
jae @02
fild dword [rip+ints-@06+$08] { 16384 }
@06: fcomip st, st(1)
jbe @00
{$IFDEF WINDOWS}
lea rdx, [rcx+$00]
mov ecx, ROUND_TOWARD_ZERO
{$ELSE}
mov edi, ROUND_TOWARD_ZERO
{$ENDIF}
call setRoundMode
fld st
fld st
frndint
{$IFDEF WINDOWS}
mov ecx, ROUND_TO_NEAREST
{$ELSE}
mov edi, ROUND_TO_NEAREST
{$ENDIF}
call setRoundMode
{$IFDEF WINDOWS}
lea rcx, [rdx+$00]
{$ENDIF}
fsubp st(1), st
f2xm1
fld1
faddp st(1), st
fscale
fstp st(1)
fld1
fld st(1)
fdivp st(1), st
fld st(1)
fld st(1)
fsubp st(1), st
fxch st(2)
fxch st(1)
faddp st(1), st
fdivp st(1), st
@exit:
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.asinh(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fxam
fnstsw ax
and eax, $00004700
cmp eax, $00000100 { не число }
je @exit
cmp eax, $00000300 { не число }
je @exit
cmp eax, $00000500 { +∞ }
je @exit
cmp eax, $00000700 { –∞ }
je @exit
fldln2
fxch st(1)
fild qword [rip+longs-@00+$20] { –2^31 }
@00: fcomip st, st(1)
jbe @01
fchs
fyl2x
fldln2
faddp st(1), st
fchs
jmp @exit
@01: fild qword [rip+longs-@02+$28] { 2^31 }
@02: fcomip st, st(1)
jae @03
fyl2x
fldln2
faddp st(1), st
jmp @exit
@03: fld st
fmul st, st
fld1
faddp st(1), st
fsqrt
faddp st(1), st
fyl2x
@exit:
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.acosh(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fxam
fnstsw ax
and eax, $00004700
cmp eax, $00000100 { не число }
je @exit
cmp eax, $00000300 { не число }
je @exit
cmp eax, $00000500 { +∞ }
je @exit
fld1
fcomip st, st(1)
jbe @01
ffree st
fincstp
fld dword [rip+floats-@00+$08] { не число }
@00: jmp @exit
@01: fldln2
fxch st(1)
fild qword [rip+longs-@02+$28] { 2^31 }
@02: fcomip st, st(1)
jae @03
fyl2x
fldln2
faddp st(1), st
jmp @exit
@03: fld st
fmul st, st
fld1
fsubp st(1), st
fsqrt
faddp st(1), st
fyl2x
@exit:
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.atanh(x: real): real; assembler; nostackframe;
asm
fld tbyte [rip+reals-@00+20] { 1.0 / 2.0 }
@00: fldln2
fld1
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
fld1
fld st(1)
faddp st(1), st
fxch st(2)
fxch st(1)
fsubp st(1), st
fdivp st(1), st
fyl2x
fmulp st(1), st
@exit:
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.ceil(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
lea rdx, [rcx+$00]
mov ecx, ROUND_UP
{$ELSE}
fld tbyte [rsp+$08]
mov edi, ROUND_UP
{$ENDIF}
call setRoundMode
frndint
{$IFDEF WINDOWS}
mov ecx, ROUND_TO_NEAREST
{$ELSE}
mov edi, ROUND_TO_NEAREST
{$ENDIF}
call setRoundMode
{$IFDEF WINDOWS}
lea rcx, [rdx+$00]
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.floor(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
lea rdx, [rcx+$00]
mov ecx, ROUND_DOWN
{$ELSE}
fld tbyte [rsp+$08]
mov edi, ROUND_DOWN
{$ENDIF}
call setRoundMode
frndint
{$IFDEF WINDOWS}
mov ecx, ROUND_TO_NEAREST
{$ELSE}
mov edi, ROUND_TO_NEAREST
{$ENDIF}
call setRoundMode
{$IFDEF WINDOWS}
lea rcx, [rdx+$00]
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.round(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
{$ELSE}
fld tbyte [rsp+$08]
{$ENDIF}
frndint
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.intPart(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
lea rdx, [rcx+$00]
mov ecx, ROUND_TOWARD_ZERO
{$ELSE}
fld tbyte [rsp+$08]
mov edi, ROUND_TOWARD_ZERO
{$ENDIF}
call setRoundMode
frndint
{$IFDEF WINDOWS}
mov ecx, ROUND_TO_NEAREST
{$ELSE}
mov edi, ROUND_TO_NEAREST
{$ENDIF}
call setRoundMode
{$IFDEF WINDOWS}
lea rcx, [rdx+$00]
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.fracPart(x: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [rdx+$00]
lea rdx, [rcx+$00]
mov ecx, ROUND_TOWARD_ZERO
{$ELSE}
fld tbyte [rsp+$08]
mov edi, ROUND_TOWARD_ZERO
{$ENDIF}
call setRoundMode
fld st
frndint
{$IFDEF WINDOWS}
mov ecx, ROUND_TO_NEAREST
{$ELSE}
mov edi, ROUND_TO_NEAREST
{$ENDIF}
call setRoundMode
{$IFDEF WINDOWS}
lea rcx, [rdx+$00]
{$ENDIF}
fsubp st(1), st
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.atan2(x, y: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [r8+$00] { y }
fld tbyte [rdx+$00] { x }
{$ELSE}
fld tbyte [rsp+$18] { y }
fld tbyte [rsp+$08] { x }
{$ENDIF}
fpatan
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.pow(x, y: real): real; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
fld tbyte [r8+$00] { y }
fld tbyte [rdx+$00] { x }
{$ELSE}
fld tbyte [rsp+$18] { y }
fld tbyte [rsp+$08] { x }
{$ENDIF}
fyl2x
fxam
fnstsw ax
and eax, $00004700
cmp eax, $00000100 { не число }
je @exit
cmp eax, $00000300 { не число }
je @exit
cmp eax, $00000500 { +∞ }
je @exit
cmp eax, $00000700 { –∞ }
jne @00
ffree st
fincstp
fldz
jmp @exit
@00:
{$IFDEF WINDOWS}
lea rdx, [rcx+$00]
mov ecx, ROUND_TOWARD_ZERO
{$ELSE}
mov edi, ROUND_TOWARD_ZERO
{$ENDIF}
call setRoundMode
fld st
fld st
frndint
{$IFDEF WINDOWS}
mov ecx, ROUND_TO_NEAREST
{$ELSE}
mov edi, ROUND_TO_NEAREST
{$ENDIF}
call setRoundMode
{$IFDEF WINDOWS}
lea rcx, [rdx+$00]
{$ENDIF}
fsubp st(1), st
f2xm1
fld1
faddp st(1), st
fscale
fstp st(1)
@exit:
{$IFDEF WINDOWS}
fstp tbyte [rcx+$00]
{$ENDIF}
end;
class function Math.toRadians(angleInDegrees: real): real;
begin
result := angleInDegrees / reals[4].value;
end;
class function Math.toDegrees(angleInRadians: real): real;
begin
result := angleInRadians * reals[4].value;
end;
{%endregion}
{%region &Array}
class procedure &Array.copyBy1(const src; var dst; length: long); assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000010c8
mov qword [rbp-$10], rsi
mov qword [rbp-$08], rdi
lea rsi, [rcx+$00]
lea rdi, [rdx+$00]
lea rcx, [r8+$00]
{$ELSE}
xchg rsi, rdi
lea rcx, [rdx+$00]
{$ENDIF}
cmp rsi, rdi
jl @back
cld
rep movsb
jmp @exit
@back: lea rsi, [rsi+rcx*1-$01]
lea rdi, [rdi+rcx*1-$01]
std
rep movsb
cld
@exit:
{$IFDEF WINDOWS}
mov rsi, [rbp-$10]
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class procedure &Array.copyBy2(const src; var dst; length: long); assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000010c8
mov qword [rbp-$10], rsi
mov qword [rbp-$08], rdi
lea rsi, [rcx+$00]
lea rdi, [rdx+$00]
lea rcx, [r8+$00]
{$ELSE}
xchg rsi, rdi
lea rcx, [rdx+$00]
{$ENDIF}
cmp rsi, rdi
jl @back
cld
rep movsw
jmp @exit
@back: lea rsi, [rsi+rcx*2-$02]
lea rdi, [rdi+rcx*2-$02]
std
rep movsw
cld
@exit:
{$IFDEF WINDOWS}
mov rsi, [rbp-$10]
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class procedure &Array.copyBy4(const src; var dst; length: long); assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000010c8
mov qword [rbp-$10], rsi
mov qword [rbp-$08], rdi
lea rsi, [rcx+$00]
lea rdi, [rdx+$00]
lea rcx, [r8+$00]
{$ELSE}
xchg rsi, rdi
lea rcx, [rdx+$00]
{$ENDIF}
cmp rsi, rdi
jl @back
cld
rep movsd
jmp @exit
@back: lea rsi, [rsi+rcx*4-$04]
lea rdi, [rdi+rcx*4-$04]
std
rep movsd
cld
@exit:
{$IFDEF WINDOWS}
mov rsi, [rbp-$10]
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class procedure &Array.copyBy8(const src; var dst; length: long); assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000010c8
mov qword [rbp-$10], rsi
mov qword [rbp-$08], rdi
lea rsi, [rcx+$00]
lea rdi, [rdx+$00]
lea rcx, [r8+$00]
{$ELSE}
xchg rsi, rdi
lea rcx, [rdx+$00]
{$ENDIF}
cmp rsi, rdi
jl @back
cld
rep movsq
jmp @exit
@back: lea rsi, [rsi+rcx*8-$08]
lea rdi, [rdi+rcx*8-$08]
std
rep movsq
cld
@exit:
{$IFDEF WINDOWS}
mov rsi, [rbp-$10]
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class procedure &Array.fillReal(var dst; length: int; const value: real); assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000008c8
mov qword [rbp-$08], rdi
lea rdi, [rcx+$00]
movsxd rcx, edx
mov rax, qword [r8+$00]
movsx rdx, word [r8+$08]
{$ELSE}
movsxd rcx, esi
mov rax, qword [rsp+$08]
movsx rdx, word [rsp+$10]
{$ENDIF}
@00: mov qword [rdi+$00], rax
mov word [rdi+$08], dx
lea rdi, [rdi+$0a]
loop @00
{$IFDEF WINDOWS}
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class procedure &Array.fillLong(var dst; size, length: int; value: long); assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000008c8
mov qword [rbp-$08], rdi
lea rdi, [rcx+$00]
lea rax, [r9+$00]
movsxd rcx, r8d
movsxd rdx, edx
{$ELSE}
lea rax, [rcx+$00]
movsxd rcx, edx
movsxd rdx, esi
{$ENDIF}
lea r10, [rip+@01-@00]
@00: movsxd r11, [r10+rdx*4+$00]
lea r10, [r10+r11*1+$00]
jmp r10
align $08
@01: dd $00000010 { @S0-@01 }
dd $00000018 { @S1-@01 }
dd $00000020 { @S2-@01 }
dd $00000028 { @S3-@01 }
@S0: cld
rep stosb
jmp @exit
align $08
@S1: cld
rep stosw
jmp @exit
align $08
@S2: cld
rep stosd
jmp @exit
align $08
@S3: cld
rep stosq
jmp @exit
align $08
@exit:
{$IFDEF WINDOWS}
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class function &Array.findfeq(const src; size, length: int; value: long): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000008c8
mov qword [rbp-$08], rdi
lea rdi, [rcx+$00]
lea rax, [r9+$00]
movsxd rcx, r8d
movsxd rdx, edx
{$ELSE}
lea rax, [rcx+$00]
movsxd rcx, edx
movsxd rdx, esi
{$ENDIF}
lea r9, [rcx-$01]
lea r10, [rip+@01-@00]
@00: movsxd r11, [r10+rdx*4+$00]
lea r10, [r10+r11*1+$00]
jmp r10
align $08
@01: dd $00000010 { @S0-@01 }
dd $00000018 { @S1-@01 }
dd $00000020 { @S2-@01 }
dd $00000028 { @S3-@01 }
@S0: cld
repne scasb
je @rpos
jmp @rneg
align $08
@S1: cld
repne scasw
je @rpos
jmp @rneg
align $08
@S2: cld
repne scasd
je @rpos
jmp @rneg
align $08
@S3: cld
repne scasq
je @rpos
jmp @rneg
align $08
@rneg: mov eax, NOT_FOUND
jmp @exit
@rpos: sub r9d, ecx
mov eax, r9d
@exit:
{$IFDEF WINDOWS}
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class function &Array.findfne(const src; size, length: int; value: long): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000008c8
mov qword [rbp-$08], rdi
lea rdi, [rcx+$00]
lea rax, [r9+$00]
movsxd rcx, r8d
movsxd rdx, edx
{$ELSE}
lea rax, [rcx+$00]
movsxd rcx, edx
movsxd rdx, esi
{$ENDIF}
lea r9, [rcx-$01]
lea r10, [rip+@01-@00]
@00: movsxd r11, [r10+rdx*4+$00]
lea r10, [r10+r11*1+$00]
jmp r10
align $08
@01: dd $00000010 { @S0-@01 }
dd $00000018 { @S1-@01 }
dd $00000020 { @S2-@01 }
dd $00000028 { @S3-@01 }
@S0: cld
repe scasb
jne @rpos
jmp @rneg
align $08
@S1: cld
repe scasw
jne @rpos
jmp @rneg
align $08
@S2: cld
repe scasd
jne @rpos
jmp @rneg
align $08
@S3: cld
repe scasq
jne @rpos
jmp @rneg
align $08
@rneg: mov eax, NOT_FOUND
jmp @exit
@rpos: sub r9d, ecx
mov eax, r9d
@exit:
{$IFDEF WINDOWS}
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class function &Array.findbeq(const src; size, length: int; value: long): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000008c8
mov qword [rbp-$08], rdi
lea rdi, [rcx+$00]
lea rax, [r9+$00]
movsxd rcx, r8d
movsxd rdx, edx
{$ELSE}
lea rax, [rcx+$00]
movsxd rcx, edx
movsxd rdx, esi
{$ENDIF}
lea r9, [rcx-$01]
lea r10, [rip+@01-@00]
@00: movsxd r11, [r10+rdx*4+$00]
lea r10, [r10+r11*1+$00]
jmp r10
align $08
@01: dd $00000010 { @S0-@01 }
dd $00000018 { @S1-@01 }
dd $00000020 { @S2-@01 }
dd $00000028 { @S3-@01 }
@S0: std
repne scasb
je @rpos
jmp @rneg
align $08
@S1: std
repne scasw
je @rpos
jmp @rneg
align $08
@S2: std
repne scasd
je @rpos
jmp @rneg
align $08
@S3: std
repne scasq
je @rpos
jmp @rneg
align $08
@rneg: mov eax, NOT_FOUND
jmp @exit
@rpos: sub ecx, r9d
mov eax, ecx
@exit: cld
{$IFDEF WINDOWS}
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class function &Array.findbne(const src; size, length: int; value: long): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000008c8
mov qword [rbp-$08], rdi
lea rdi, [rcx+$00]
lea rax, [r9+$00]
movsxd rcx, r8d
movsxd rdx, edx
{$ELSE}
lea rax, [rcx+$00]
movsxd rcx, edx
movsxd rdx, esi
{$ENDIF}
lea r9, [rcx-$01]
lea r10, [rip+@01-@00]
@00: movsxd r11, [r10+rdx*4+$00]
lea r10, [r10+r11*1+$00]
jmp r10
align $08
@01: dd $00000010 { @S0-@01 }
dd $00000018 { @S1-@01 }
dd $00000020 { @S2-@01 }
dd $00000028 { @S3-@01 }
@S0: std
repe scasb
jne @rpos
jmp @rneg
align $08
@S1: std
repe scasw
jne @rpos
jmp @rneg
align $08
@S2: std
repe scasd
jne @rpos
jmp @rneg
align $08
@S3: std
repe scasq
jne @rpos
jmp @rneg
align $08
@rneg: mov eax, NOT_FOUND
jmp @exit
@rpos: sub ecx, r9d
mov eax, ecx
@exit: cld
{$IFDEF WINDOWS}
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class function &Array.compfeq(const src1, src2; size, length: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000010c8
mov qword [rbp-$10], rsi
mov qword [rbp-$08], rdi
lea rsi, [rcx+$00]
lea rdi, [rdx+$00]
movsxd rcx, r9d
movsxd rdx, r8d
{$ELSE}
xchg rsi, rdi
movsxd rcx, ecx
movsxd rdx, edx
{$ENDIF}
lea r9, [rcx-$01]
lea r10, [rip+@01-@00]
@00: movsxd r11, [r10+rdx*4+$00]
lea r10, [r10+r11*1+$00]
jmp r10
align $08
@01: dd $00000010 { @S0-@01 }
dd $00000018 { @S1-@01 }
dd $00000020 { @S2-@01 }
dd $00000028 { @S3-@01 }
@S0: cld
repne cmpsb
je @rpos
jmp @rneg
align $08
@S1: cld
repne cmpsw
je @rpos
jmp @rneg
align $08
@S2: cld
repne cmpsd
je @rpos
jmp @rneg
align $08
@S3: cld
repne cmpsq
je @rpos
jmp @rneg
align $08
@rneg: mov eax, NOT_FOUND
jmp @exit
@rpos: sub r9d, ecx
mov eax, r9d
@exit:
{$IFDEF WINDOWS}
mov rsi, [rbp-$10]
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class function &Array.compfne(const src1, src2; size, length: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000010c8
mov qword [rbp-$10], rsi
mov qword [rbp-$08], rdi
lea rsi, [rcx+$00]
lea rdi, [rdx+$00]
movsxd rcx, r9d
movsxd rdx, r8d
{$ELSE}
xchg rsi, rdi
movsxd rcx, ecx
movsxd rdx, edx
{$ENDIF}
lea r9, [rcx-$01]
lea r10, [rip+@01-@00]
@00: movsxd r11, [r10+rdx*4+$00]
lea r10, [r10+r11*1+$00]
jmp r10
align $08
@01: dd $00000010 { @S0-@01 }
dd $00000018 { @S1-@01 }
dd $00000020 { @S2-@01 }
dd $00000028 { @S3-@01 }
@S0: cld
repe cmpsb
jne @rpos
jmp @rneg
align $08
@S1: cld
repe cmpsw
jne @rpos
jmp @rneg
align $08
@S2: cld
repe cmpsd
jne @rpos
jmp @rneg
align $08
@S3: cld
repe cmpsq
jne @rpos
jmp @rneg
align $08
@rneg: mov eax, NOT_FOUND
jmp @exit
@rpos: sub r9d, ecx
mov eax, r9d
@exit:
{$IFDEF WINDOWS}
mov rsi, [rbp-$10]
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class function &Array.compbeq(const src1, src2; size, length: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000010c8
mov qword [rbp-$10], rsi
mov qword [rbp-$08], rdi
lea rsi, [rcx+$00]
lea rdi, [rdx+$00]
movsxd rcx, r9d
movsxd rdx, r8d
{$ELSE}
xchg rsi, rdi
movsxd rcx, ecx
movsxd rdx, edx
{$ENDIF}
lea r9, [rcx-$01]
lea r10, [rip+@01-@00]
@00: movsxd r11, [r10+rdx*4+$00]
lea r10, [r10+r11*1+$00]
jmp r10
align $08
@01: dd $00000010 { @S0-@01 }
dd $00000018 { @S1-@01 }
dd $00000020 { @S2-@01 }
dd $00000028 { @S3-@01 }
@S0: std
repne cmpsb
je @rpos
jmp @rneg
align $08
@S1: std
repne cmpsw
je @rpos
jmp @rneg
align $08
@S2: std
repne cmpsd
je @rpos
jmp @rneg
align $08
@S3: std
repne cmpsq
je @rpos
jmp @rneg
align $08
@rneg: mov eax, NOT_FOUND
jmp @exit
@rpos: sub ecx, r9d
mov eax, ecx
@exit: cld
{$IFDEF WINDOWS}
mov rsi, [rbp-$10]
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class function &Array.compbne(const src1, src2; size, length: int): int; assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000010c8
mov qword [rbp-$10], rsi
mov qword [rbp-$08], rdi
lea rsi, [rcx+$00]
lea rdi, [rdx+$00]
movsxd rcx, r9d
movsxd rdx, r8d
{$ELSE}
xchg rsi, rdi
movsxd rcx, ecx
movsxd rdx, edx
{$ENDIF}
lea r9, [rcx-$01]
lea r10, [rip+@01-@00]
@00: movsxd r11, [r10+rdx*4+$00]
lea r10, [r10+r11*1+$00]
jmp r10
align $08
@01: dd $00000010 { @S0-@01 }
dd $00000018 { @S1-@01 }
dd $00000020 { @S2-@01 }
dd $00000028 { @S3-@01 }
@S0: std
repe cmpsb
jne @rpos
jmp @rneg
align $08
@S1: std
repe cmpsw
jne @rpos
jmp @rneg
align $08
@S2: std
repe cmpsd
jne @rpos
jmp @rneg
align $08
@S3: std
repe cmpsq
jne @rpos
jmp @rneg
align $08
@rneg: mov eax, NOT_FOUND
jmp @exit
@rpos: sub ecx, r9d
mov eax, ecx
@exit: cld
{$IFDEF WINDOWS}
mov rsi, [rbp-$10]
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class procedure &Array.checkBounds(const aarray; offset, length: int);
var
lim: int;
len: int;
begin
lim := offset + length;
len := system.length(boolean_Array1d(aarray));
if (lim < offset) or (lim > len) or (offset < 0) or (offset > len) then begin
raise ArrayIndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.array-index'));
end;
end;
class procedure &Array.copyRaw(const src; var dst; length: long); assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000010c8
mov qword [rbp-$10], rsi
mov qword [rbp-$08], rdi
lea rsi, [rcx-$00]
lea rdi, [rdx-$00]
lea rcx, [r8-$00]
{$ELSE}
xchg rsi, rdi
lea rcx, [rdx-$00]
{$ENDIF}
cmp rcx, $00
jle @exit
cmp rsi, rdi
jl @back
mov rdx, rcx
{$IFDEF USE_AVX2}
sar rcx, $05
and rdx, $1f
jrcxz @01
@00: vmovdqu ymm0, [rsi+$00]
vmovdqu ymmword [rdi+$00], ymm0
lea rsi, [rsi+$20]
lea rdi, [rdi+$20]
{$ELSE}
sar rcx, $04
and rdx, $0f
jrcxz @01
@00: movdqu xmm0, [rsi+$00]
movdqu xmmword [rdi+$00], xmm0
lea rsi, [rsi+$10]
lea rdi, [rdi+$10]
{$ENDIF}
loop @00
@01: mov rcx, rdx
jrcxz @exit
cld
rep movsb
jmp @exit
@back: lea rsi, [rsi+rcx*1-$00]
lea rdi, [rdi+rcx*1-$00]
mov rdx, rcx
{$IFDEF USE_AVX2}
sar rcx, $05
and rdx, $1f
jrcxz @03
@02: lea rsi, [rsi-$20]
lea rdi, [rdi-$20]
vmovdqu ymm0, [rsi-$00]
vmovdqu ymmword [rdi-$00], ymm0
{$ELSE}
sar rcx, $04
and rdx, $0f
jrcxz @03
@02: lea rsi, [rsi-$10]
lea rdi, [rdi-$10]
movdqu xmm0, [rsi-$00]
movdqu xmmword [rdi-$00], xmm0
{$ENDIF}
loop @02
@03: mov rcx, rdx
jrcxz @exit
lea rsi, [rsi-$01]
lea rdi, [rdi-$01]
std
rep movsb
cld
@exit:
{$IFDEF WINDOWS}
mov rsi, [rbp-$10]
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class procedure &Array.copyPrimitives(const srcArray: boolean_Array1d; srcOffset: int; const dstArray: boolean_Array1d; dstOffset: int; length: int);
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
copyRaw(srcArray[srcOffset], dstArray[dstOffset], long(length) * sizeof(boolean));
end;
end;
class procedure &Array.copyPrimitives(const srcArray: char_Array1d; srcOffset: int; const dstArray: char_Array1d; dstOffset: int; length: int);
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
copyRaw(srcArray[srcOffset], dstArray[dstOffset], long(length) * sizeof(char));
end;
end;
class procedure &Array.copyPrimitives(const srcArray: uchar_Array1d; srcOffset: int; const dstArray: uchar_Array1d; dstOffset: int; length: int);
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
copyRaw(srcArray[srcOffset], dstArray[dstOffset], long(length) * sizeof(uchar));
end;
end;
class procedure &Array.copyPrimitives(const srcArray: byte_Array1d; srcOffset: int; const dstArray: byte_Array1d; dstOffset: int; length: int);
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
copyRaw(srcArray[srcOffset], dstArray[dstOffset], long(length) * sizeof(byte));
end;
end;
class procedure &Array.copyPrimitives(const srcArray: short_Array1d; srcOffset: int; const dstArray: short_Array1d; dstOffset: int; length: int);
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
copyRaw(srcArray[srcOffset], dstArray[dstOffset], long(length) * sizeof(short));
end;
end;
class procedure &Array.copyPrimitives(const srcArray: int_Array1d; srcOffset: int; const dstArray: int_Array1d; dstOffset: int; length: int);
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
copyRaw(srcArray[srcOffset], dstArray[dstOffset], long(length) * sizeof(int));
end;
end;
class procedure &Array.copyPrimitives(const srcArray: long_Array1d; srcOffset: int; const dstArray: long_Array1d; dstOffset: int; length: int);
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
copyRaw(srcArray[srcOffset], dstArray[dstOffset], long(length) * sizeof(long));
end;
end;
class procedure &Array.copyPrimitives(const srcArray: float_Array1d; srcOffset: int; const dstArray: float_Array1d; dstOffset: int; length: int);
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
copyRaw(srcArray[srcOffset], dstArray[dstOffset], long(length) * sizeof(float));
end;
end;
class procedure &Array.copyPrimitives(const srcArray: double_Array1d; srcOffset: int; const dstArray: double_Array1d; dstOffset: int; length: int);
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
copyRaw(srcArray[srcOffset], dstArray[dstOffset], long(length) * sizeof(double));
end;
end;
class procedure &Array.copyPrimitives(const srcArray: real_Array1d; srcOffset: int; const dstArray: real_Array1d; dstOffset: int; length: int);
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
copyRaw(srcArray[srcOffset], dstArray[dstOffset], long(length) * sizeof(real));
end;
end;
class procedure &Array.copyStrings(const srcArray: AnsiString_Array1d; srcOffset: int; const dstArray: AnsiString_Array1d; dstOffset: int; length: int);
var
idx: int;
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
if (srcArray = dstArray) and (srcOffset < dstOffset) then begin
inc(srcOffset, length);
inc(dstOffset, length);
for idx := length - 1 downto 0 do begin
dec(srcOffset);
dec(dstOffset);
dstArray[dstOffset] := srcArray[srcOffset];
end;
end else begin
for idx := length - 1 downto 0 do begin
dstArray[dstOffset] := srcArray[srcOffset];
inc(srcOffset);
inc(dstOffset);
end;
end;
end;
end;
class procedure &Array.copyStrings(const srcArray: UnicodeString_Array1d; srcOffset: int; const dstArray: UnicodeString_Array1d; dstOffset: int; length: int);
var
idx: int;
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
if (srcArray = dstArray) and (srcOffset < dstOffset) then begin
inc(srcOffset, length);
inc(dstOffset, length);
for idx := length - 1 downto 0 do begin
dec(srcOffset);
dec(dstOffset);
dstArray[dstOffset] := srcArray[srcOffset];
end;
end else begin
for idx := length - 1 downto 0 do begin
dstArray[dstOffset] := srcArray[srcOffset];
inc(srcOffset);
inc(dstOffset);
end;
end;
end;
end;
class procedure &Array.copyObjects(const srcArray; srcOffset: int; const dstArray; dstOffset: int; length: int);
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
copyRaw(TObject_Array1d(srcArray)[srcOffset], TObject_Array1d(dstArray)[dstOffset], long(length) * sizeof(TObject));
end;
end;
class procedure &Array.copySimples(const srcArray; srcOffset: int; const dstArray; dstOffset: int; length: int);
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
copyRaw(ISimple_Array1d(srcArray)[srcOffset], ISimple_Array1d(dstArray)[dstOffset], long(length) * sizeof(ISimple));
end;
end;
class procedure &Array.copyUnknowns(const srcArray; srcOffset: int; const dstArray; dstOffset: int; length: int);
var
idx: int;
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
if (IUnknown_Array1d(srcArray) = IUnknown_Array1d(dstArray)) and (srcOffset < dstOffset) then begin
inc(srcOffset, length);
inc(dstOffset, length);
for idx := length - 1 downto 0 do begin
dec(srcOffset);
dec(dstOffset);
IUnknown_Array1d(dstArray)[dstOffset] := IUnknown_Array1d(srcArray)[srcOffset];
end;
end else begin
for idx := length - 1 downto 0 do begin
IUnknown_Array1d(dstArray)[dstOffset] := IUnknown_Array1d(srcArray)[srcOffset];
inc(srcOffset);
inc(dstOffset);
end;
end;
end;
end;
class procedure &Array.copyArrays(const srcArray; srcOffset: int; const dstArray; dstOffset: int; length: int);
var
idx: int;
begin
if length > 0 then begin
checkBounds(srcArray, srcOffset, length);
checkBounds(dstArray, dstOffset, length);
if (boolean_Array2d(srcArray) = boolean_Array2d(dstArray)) and (srcOffset < dstOffset) then begin
inc(srcOffset, length);
inc(dstOffset, length);
for idx := length - 1 downto 0 do begin
dec(srcOffset);
dec(dstOffset);
boolean_Array2d(dstArray)[dstOffset] := boolean_Array2d(srcArray)[srcOffset];
end;
end else begin
for idx := length - 1 downto 0 do begin
boolean_Array2d(dstArray)[dstOffset] := boolean_Array2d(srcArray)[srcOffset];
inc(srcOffset);
inc(dstOffset);
end;
end;
end;
end;
class procedure &Array.zeroRaw(out dst; length: long); assembler; nostackframe;
asm
{$IFDEF WINDOWS}
dd $000008c8
mov qword [rbp-$08], rdi
lea rdi, [rcx+$00]
lea rcx, [rdx+$00]
{$ELSE}
lea rcx, [rsi+$00]
{$ENDIF}
cmp rcx, $00
jle @exit
mov rdx, rcx
{$IFDEF USE_AVX2}
sar rcx, $05
and rdx, $1f
jrcxz @01
vpxor ymm0, ymm0, ymm0
@00: vmovdqu ymmword [rdi+$00], ymm0
lea rdi, [rdi+$20]
{$ELSE}
sar rcx, $04
and rdx, $0f
jrcxz @01
pxor xmm0, xmm0
@00: movdqu xmmword [rdi+$00], xmm0
lea rdi, [rdi+$00]
{$ENDIF}
loop @00
@01: mov rcx, rdx
jrcxz @exit
xor eax, eax
cld
rep stosb
@exit:
{$IFDEF WINDOWS}
mov rdi, [rbp-$08]
leave
{$ENDIF}
end;
class procedure &Array.fillPrimitives(const dstArray: boolean_Array1d; dstOffset: int; length: int; value: boolean);
var
intvl: byte absolute value;
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
fillLong(dstArray[dstOffset], 0, length, intvl);
end;
end;
class procedure &Array.fillPrimitives(const dstArray: char_Array1d; dstOffset: int; length: int; value: char);
var
intvl: byte absolute value;
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
fillLong(dstArray[dstOffset], 0, length, intvl);
end;
end;
class procedure &Array.fillPrimitives(const dstArray: uchar_Array1d; dstOffset: int; length: int; value: uchar);
var
intvl: short absolute value;
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
fillLong(dstArray[dstOffset], 1, length, intvl);
end;
end;
class procedure &Array.fillPrimitives(const dstArray: byte_Array1d; dstOffset: int; length: int; value: byte);
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
fillLong(dstArray[dstOffset], 0, length, value);
end;
end;
class procedure &Array.fillPrimitives(const dstArray: short_Array1d; dstOffset: int; length: int; value: short);
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
fillLong(dstArray[dstOffset], 1, length, value);
end;
end;
class procedure &Array.fillPrimitives(const dstArray: int_Array1d; dstOffset: int; length: int; value: int);
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
fillLong(dstArray[dstOffset], 2, length, value);
end;
end;
class procedure &Array.fillPrimitives(const dstArray: long_Array1d; dstOffset: int; length: int; value: long);
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
fillLong(dstArray[dstOffset], 3, length, value);
end;
end;
class procedure &Array.fillPrimitives(const dstArray: float_Array1d; dstOffset: int; length: int; value: float);
var
intvl: int absolute value;
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
fillLong(dstArray[dstOffset], 2, length, intvl);
end;
end;
class procedure &Array.fillPrimitives(const dstArray: double_Array1d; dstOffset: int; length: int; value: double);
var
intvl: long absolute value;
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
fillLong(dstArray[dstOffset], 3, length, intvl);
end;
end;
class procedure &Array.fillPrimitives(const dstArray: real_Array1d; dstOffset: int; length: int; value: real);
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
fillReal(dstArray[dstOffset], length, value);
end;
end;
class procedure &Array.fillStrings(const dstArray: AnsiString_Array1d; dstOffset: int; length: int; const value: AnsiString);
var
index: int;
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
for index := dstOffset to dstOffset + length - 1 do dstArray[index] := value;
end;
end;
class procedure &Array.fillStrings(const dstArray: UnicodeString_Array1d; dstOffset: int; length: int; const value: UnicodeString);
var
index: int;
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
for index := dstOffset to dstOffset + length - 1 do dstArray[index] := value;
end;
end;
class procedure &Array.fillObjects(const dstArray; dstOffset: int; length: int; value: TObject);
var
intvl: long absolute value;
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
fillLong(TObject_Array1d(dstArray)[dstOffset], 3, length, intvl);
end;
end;
class procedure &Array.fillSimples(const dstArray; dstOffset: int; length: int; value: ISimple);
var
intvl: long absolute value;
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
fillLong(ISimple_Array1d(dstArray)[dstOffset], 3, length, intvl);
end;
end;
class procedure &Array.fillUnknowns(const dstArray; dstOffset: int; length: int; value: IUnknown);
var
index: int;
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
for index := dstOffset to dstOffset + length - 1 do IUnknown_Array1d(dstArray)[index] := value;
end;
end;
class procedure &Array.fillArrays(const dstArray; dstOffset: int; length: int; const value);
var
index: int;
begin
if length > 0 then begin
checkBounds(dstArray, dstOffset, length);
for index := dstOffset to dstOffset + length - 1 do boolean_Array2d(dstArray)[index] := boolean_Array1d(value);
end;
end;
class function &Array.indexOf(value: boolean; const aarray: boolean_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
intvl: byte absolute value;
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfeq(aarray[startFromIndex], 0, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOf(value: char; const aarray: char_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
intvl: byte absolute value;
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfeq(aarray[startFromIndex], 0, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOf(value: uchar; const aarray: uchar_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
intvl: short absolute value;
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfeq(aarray[startFromIndex], 1, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOf(value: int; const aarray: byte_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfeq(aarray[startFromIndex], 0, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOf(value: int; const aarray: short_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfeq(aarray[startFromIndex], 1, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOf(value: int; const aarray: int_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfeq(aarray[startFromIndex], 2, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOf(value: long; const aarray: long_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfeq(aarray[startFromIndex], 3, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOf(value: Pointer; const aarray; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
intvl: long absolute value;
parray: Pointer_Array1d absolute aarray;
begin
if parray <> nil then begin
arrayLength := length(parray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfeq(parray[startFromIndex], 3, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOf(value: boolean; const aarray: boolean_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
intvl: byte absolute value;
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbeq(aarray[startFromIndex], 0, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOf(value: char; const aarray: char_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
intvl: byte absolute value;
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbeq(aarray[startFromIndex], 0, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOf(value: uchar; const aarray: uchar_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
intvl: short absolute value;
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbeq(aarray[startFromIndex], 1, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOf(value: int; const aarray: byte_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbeq(aarray[startFromIndex], 0, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOf(value: int; const aarray: short_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbeq(aarray[startFromIndex], 1, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOf(value: int; const aarray: int_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbeq(aarray[startFromIndex], 2, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOf(value: long; const aarray: long_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbeq(aarray[startFromIndex], 3, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOf(value: Pointer; const aarray; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
intvl: long absolute value;
parray: Pointer_Array1d absolute aarray;
begin
if parray <> nil then begin
arrayLength := length(parray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbeq(parray[startFromIndex], 3, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOfNon(value: boolean; const aarray: boolean_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
intvl: byte absolute value;
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfne(aarray[startFromIndex], 0, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOfNon(value: char; const aarray: char_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
intvl: byte absolute value;
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfne(aarray[startFromIndex], 0, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOfNon(value: uchar; const aarray: uchar_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
intvl: short absolute value;
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfne(aarray[startFromIndex], 1, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOfNon(value: int; const aarray: byte_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfne(aarray[startFromIndex], 0, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOfNon(value: int; const aarray: short_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfne(aarray[startFromIndex], 1, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOfNon(value: int; const aarray: int_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfne(aarray[startFromIndex], 2, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOfNon(value: long; const aarray: long_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfne(aarray[startFromIndex], 3, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.indexOfNon(value: Pointer; const aarray; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
intvl: long absolute value;
parray: Pointer_Array1d absolute aarray;
begin
if parray <> nil then begin
arrayLength := length(parray);
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex < arrayLength then begin
limitScanLength := arrayLength - startFromIndex;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findfne(parray[startFromIndex], 3, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOfNon(value: boolean; const aarray: boolean_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
intvl: byte absolute value;
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbne(aarray[startFromIndex], 0, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOfNon(value: char; const aarray: char_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
intvl: byte absolute value;
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbne(aarray[startFromIndex], 0, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOfNon(value: uchar; const aarray: uchar_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
intvl: short absolute value;
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbne(aarray[startFromIndex], 1, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOfNon(value: int; const aarray: byte_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbne(aarray[startFromIndex], 0, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOfNon(value: int; const aarray: short_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbne(aarray[startFromIndex], 1, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOfNon(value: int; const aarray: int_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbne(aarray[startFromIndex], 2, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOfNon(value: long; const aarray: long_Array1d; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
begin
if aarray <> nil then begin
arrayLength := length(aarray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbne(aarray[startFromIndex], 3, limitScanLength, value);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.lastIndexOfNon(value: Pointer; const aarray; startFromIndex: int; maximumScanLength: int): int;
var
found: int;
arrayLength: int;
limitScanLength: int;
intvl: long absolute value;
parray: Pointer_Array1d absolute aarray;
begin
if parray <> nil then begin
arrayLength := length(parray);
if startFromIndex >= arrayLength then begin
startFromIndex := arrayLength - 1;
end;
if startFromIndex >= 0 then begin
limitScanLength := startFromIndex + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
found := findbne(parray[startFromIndex], 3, limitScanLength, intvl);
if found <> NOT_FOUND then begin
result := startFromIndex + found;
exit;
end;
end;
end;
result := -1;
end;
class function &Array.offsetOfEqual(const array1: boolean_Array1d; array1StartFromIndex: int; const array2: boolean_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: boolean_Array1d absolute array1;
array2Instance: boolean_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 0, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfEqual(const array1: char_Array1d; array1StartFromIndex: int; const array2: char_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: char_Array1d absolute array1;
array2Instance: char_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 0, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfEqual(const array1: uchar_Array1d; array1StartFromIndex: int; const array2: uchar_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: uchar_Array1d absolute array1;
array2Instance: uchar_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 1, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfEqual(const array1: byte_Array1d; array1StartFromIndex: int; const array2: byte_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: byte_Array1d absolute array1;
array2Instance: byte_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 0, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfEqual(const array1: short_Array1d; array1StartFromIndex: int; const array2: short_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: short_Array1d absolute array1;
array2Instance: short_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 1, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfEqual(const array1: int_Array1d; array1StartFromIndex: int; const array2: int_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: int_Array1d absolute array1;
array2Instance: int_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 2, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfEqual(const array1: long_Array1d; array1StartFromIndex: int; const array2: long_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: long_Array1d absolute array1;
array2Instance: long_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 3, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfEqualPtr(const array1; array1StartFromIndex: int; const array2; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: Pointer_Array1d absolute array1;
array2Instance: Pointer_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 3, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfNonEqual(const array1: boolean_Array1d; array1StartFromIndex: int; const array2: boolean_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: boolean_Array1d absolute array1;
array2Instance: boolean_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 0, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfNonEqual(const array1: char_Array1d; array1StartFromIndex: int; const array2: char_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: char_Array1d absolute array1;
array2Instance: char_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 0, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfNonEqual(const array1: uchar_Array1d; array1StartFromIndex: int; const array2: uchar_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: uchar_Array1d absolute array1;
array2Instance: uchar_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 1, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfNonEqual(const array1: byte_Array1d; array1StartFromIndex: int; const array2: byte_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: byte_Array1d absolute array1;
array2Instance: byte_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 0, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfNonEqual(const array1: short_Array1d; array1StartFromIndex: int; const array2: short_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: short_Array1d absolute array1;
array2Instance: short_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 1, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfNonEqual(const array1: int_Array1d; array1StartFromIndex: int; const array2: int_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: int_Array1d absolute array1;
array2Instance: int_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 2, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfNonEqual(const array1: long_Array1d; array1StartFromIndex: int; const array2: long_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: long_Array1d absolute array1;
array2Instance: long_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 3, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.offsetOfNonEqualPtr(const array1; array1StartFromIndex: int; const array2; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: Pointer_Array1d absolute array1;
array2Instance: Pointer_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex < 0 then begin
array1StartFromIndex := 0;
end;
if array1StartFromIndex < array1Length then begin
array2Length := length(array2Instance);
if array2StartFromIndex < 0 then begin
array2StartFromIndex := 0;
end;
if array2StartFromIndex < array2Length then begin
limitScanLength := CoInt.min(array1Length - array1StartFromIndex, array2Length - array2StartFromIndex);
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compfne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 3, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfEqual(const array1: boolean_Array1d; array1StartFromIndex: int; const array2: boolean_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: boolean_Array1d absolute array1;
array2Instance: boolean_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 0, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfEqual(const array1: char_Array1d; array1StartFromIndex: int; const array2: char_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: char_Array1d absolute array1;
array2Instance: char_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 0, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfEqual(const array1: uchar_Array1d; array1StartFromIndex: int; const array2: uchar_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: uchar_Array1d absolute array1;
array2Instance: uchar_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 1, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfEqual(const array1: byte_Array1d; array1StartFromIndex: int; const array2: byte_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: byte_Array1d absolute array1;
array2Instance: byte_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 0, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfEqual(const array1: short_Array1d; array1StartFromIndex: int; const array2: short_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: short_Array1d absolute array1;
array2Instance: short_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 1, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfEqual(const array1: int_Array1d; array1StartFromIndex: int; const array2: int_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: int_Array1d absolute array1;
array2Instance: int_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 2, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfEqual(const array1: long_Array1d; array1StartFromIndex: int; const array2: long_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: long_Array1d absolute array1;
array2Instance: long_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 3, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfEqualPtr(const array1; array1StartFromIndex: int; const array2; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: Pointer_Array1d absolute array1;
array2Instance: Pointer_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbeq(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 3, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfNonEqual(const array1: boolean_Array1d; array1StartFromIndex: int; const array2: boolean_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: boolean_Array1d absolute array1;
array2Instance: boolean_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 0, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfNonEqual(const array1: char_Array1d; array1StartFromIndex: int; const array2: char_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: char_Array1d absolute array1;
array2Instance: char_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 0, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfNonEqual(const array1: uchar_Array1d; array1StartFromIndex: int; const array2: uchar_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: uchar_Array1d absolute array1;
array2Instance: uchar_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 1, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfNonEqual(const array1: byte_Array1d; array1StartFromIndex: int; const array2: byte_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: byte_Array1d absolute array1;
array2Instance: byte_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 0, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfNonEqual(const array1: short_Array1d; array1StartFromIndex: int; const array2: short_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: short_Array1d absolute array1;
array2Instance: short_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 1, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfNonEqual(const array1: int_Array1d; array1StartFromIndex: int; const array2: int_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: int_Array1d absolute array1;
array2Instance: int_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 2, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfNonEqual(const array1: long_Array1d; array1StartFromIndex: int; const array2: long_Array1d; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: long_Array1d absolute array1;
array2Instance: long_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 3, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.negOffsetOfNonEqualPtr(const array1; array1StartFromIndex: int; const array2; array2StartFromIndex: int; maximumScanLength: int): int;
var
array1Length: int;
array2Length: int;
limitScanLength: int;
array1Instance: Pointer_Array1d absolute array1;
array2Instance: Pointer_Array1d absolute array2;
begin
if (array1Instance <> nil) and (array2Instance <> nil) then begin
array1Length := length(array1Instance);
if array1StartFromIndex >= array1Length then begin
array1StartFromIndex := array1Length - 1;
end;
if array1StartFromIndex >= 0 then begin
array2Length := length(array2Instance);
if array2StartFromIndex >= array2Length then begin
array2StartFromIndex := array2Length - 1;
end;
if array2StartFromIndex >= 0 then begin
limitScanLength := CoInt.min(array1StartFromIndex, array2StartFromIndex) + 1;
if (maximumScanLength > 0) and (limitScanLength > maximumScanLength) then limitScanLength := maximumScanLength;
result := compbne(array1Instance[array1StartFromIndex], array2Instance[array2StartFromIndex], 3, limitScanLength);
exit;
end;
end;
end;
result := NOT_FOUND;
end;
class function &Array.newBoolean1d(length: int): boolean_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newBoolean1d(const components: array of boolean): boolean_Array1d;
var
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
copyBy1(components[0], result[0], long(len));
end;
end;
class function &Array.newChar1d(length: int): char_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newChar1d(const components: array of char): char_Array1d;
var
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
copyBy1(components[0], result[0], long(len));
end;
end;
class function &Array.newUChar1d(length: int): uchar_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newUChar1d(const components: array of uchar): uchar_Array1d;
var
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
copyBy2(components[0], result[0], long(len));
end;
end;
class function &Array.newByte1d(length: int): byte_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newByte1d(const components: array of byte): byte_Array1d;
var
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
copyBy1(components[0], result[0], long(len));
end;
end;
class function &Array.newShort1d(length: int): short_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newShort1d(const components: array of short): short_Array1d;
var
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
copyBy2(components[0], result[0], long(len));
end;
end;
class function &Array.newInt1d(length: int): int_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newInt1d(const components: array of int): int_Array1d;
var
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
copyBy4(components[0], result[0], long(len));
end;
end;
class function &Array.newLong1d(length: int): long_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newLong1d(const components: array of long): long_Array1d;
var
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
copyBy8(components[0], result[0], long(len));
end;
end;
class function &Array.newFloat1d(length: int): float_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newFloat1d(const components: array of float): float_Array1d;
var
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
copyBy4(components[0], result[0], long(len));
end;
end;
class function &Array.newDouble1d(length: int): double_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newDouble1d(const components: array of double): double_Array1d;
var
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
copyBy8(components[0], result[0], long(len));
end;
end;
class function &Array.newReal1d(length: int): real_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newReal1d(const components: array of real): real_Array1d;
var
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
copyBy2(components[0], result[0], long(len) * 5);
end;
end;
class function &Array.newAnsiString1d(length: int): AnsiString_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newAnsiString1d(const components: array of AnsiString): AnsiString_Array1d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newUnicodeString1d(length: int): UnicodeString_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newUnicodeString1d(const components: array of UnicodeString): UnicodeString_Array1d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newPointer1d(length: int): Pointer_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newPointer1d(const components: array of Pointer): Pointer_Array1d;
var
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
copyBy8(components[0], result[0], long(len));
end;
end;
class function &Array.newTObject1d(length: int): TObject_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newTObject1d(const components: array of TObject): TObject_Array1d;
var
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
copyBy8(components[0], result[0], long(len));
end;
end;
class function &Array.newISimple1d(length: int): ISimple_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newISimple1d(const components: array of ISimple): ISimple_Array1d;
var
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
copyBy8(components[0], result[0], long(len));
end;
end;
class function &Array.newIUnknown1d(length: int): IUnknown_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newIUnknown1d(const components: array of IUnknown): IUnknown_Array1d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newBoolean2d(length: int): boolean_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newBoolean2d(length1, length2: int): boolean_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newBoolean2d(const components: array of boolean_Array1d): boolean_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newChar2d(length: int): char_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newChar2d(length1, length2: int): char_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newChar2d(const components: array of char_Array1d): char_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newUChar2d(length: int): uchar_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newUChar2d(length1, length2: int): uchar_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newUChar2d(const components: array of uchar_Array1d): uchar_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newByte2d(length: int): byte_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newByte2d(length1, length2: int): byte_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newByte2d(const components: array of byte_Array1d): byte_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newShort2d(length: int): short_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newShort2d(length1, length2: int): short_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newShort2d(const components: array of short_Array1d): short_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newInt2d(length: int): int_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newInt2d(length1, length2: int): int_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newInt2d(const components: array of int_Array1d): int_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newLong2d(length: int): long_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newLong2d(length1, length2: int): long_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newLong2d(const components: array of long_Array1d): long_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newFloat2d(length: int): float_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newFloat2d(length1, length2: int): float_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newFloat2d(const components: array of float_Array1d): float_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newDouble2d(length: int): double_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newDouble2d(length1, length2: int): double_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newDouble2d(const components: array of double_Array1d): double_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newReal2d(length: int): real_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newReal2d(length1, length2: int): real_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newReal2d(const components: array of real_Array1d): real_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newAnsiString2d(length: int): AnsiString_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newAnsiString2d(length1, length2: int): AnsiString_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newAnsiString2d(const components: array of AnsiString_Array1d): AnsiString_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newUnicodeString2d(length: int): UnicodeString_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newUnicodeString2d(length1, length2: int): UnicodeString_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newUnicodeString2d(const components: array of UnicodeString_Array1d): UnicodeString_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newPointer2d(length: int): Pointer_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newPointer2d(length1, length2: int): Pointer_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newPointer2d(const components: array of Pointer_Array1d): Pointer_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newTObject2d(length: int): TObject_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newTObject2d(length1, length2: int): TObject_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newTObject2d(const components: array of TObject_Array1d): TObject_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newISimple2d(length: int): ISimple_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newISimple2d(length1, length2: int): ISimple_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newISimple2d(const components: array of ISimple_Array1d): ISimple_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
class function &Array.newIUnknown2d(length: int): IUnknown_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
setLength(result, length);
end;
class function &Array.newIUnknown2d(length1, length2: int): IUnknown_Array2d;
var
idx: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'negative-array-length'));
end;
result := nil;
if length1 > 0 then begin
setLength(result, length1);
if length2 > 0 then begin
for idx := length1 - 1 downto 0 do setLength(result[idx], length2);
end;
end;
end;
class function &Array.newIUnknown2d(const components: array of IUnknown_Array1d): IUnknown_Array2d;
var
idx: int;
len: int;
begin
result := nil;
len := length(components);
if len > 0 then begin
setLength(result, len);
for idx := len - 1 downto 0 do result[idx] := components[idx];
end;
end;
{%endregion}
{%region TObjectExtended}
class function TObjectExtended.getPropertyInfo(const name: AnsiString): PPropInfo;
var
idx: int;
len: int;
lennm: int;
lownm: AnsiString;
prpnm: AnsiString;
pinfo: PPropInfo;
tinfo: PTypeInfo;
tdata: PTypeData;
begin
lownm := name.toLowerCase();
lennm := lownm.length;
tinfo := PTypeInfo(classInfo());
while tinfo <> nil do begin
tdata := getTypeData(tinfo);
pinfo := PPropInfo(Pointer(@(tdata^.unitName[1])) + int(tdata^.unitName[0]));
len := system.PUInt16(pinfo)^;
pinfo := Pointer(pinfo) + 2;
for idx := len - 1 downto 0 do begin
prpnm := pinfo^.name;
if (prpnm.length = lennm) and (prpnm.toLowerCase() = lownm) then begin
result := pinfo;
exit;
end;
pinfo := PPropInfo(Pointer(@(pinfo^.name[1])) + int(pinfo^.name[0]));
end;
tinfo := tdata^.parentInfo;
end;
result := nil;
end;
procedure TObjectExtended.writePropertyOfBoolean(const name: AnsiString; const value: boolean);
type
ProcedureWriteIndexedValueOfBoolean = procedure(index: int; value: boolean) of object;
ProcedureWriteValueOfBoolean = procedure(value: boolean) of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(pinfo^.propType);
case propertyTypeKind of
Lang.TYPE_BOOLEAN: begin
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := (transferDataKind shr 2) and $03;
case transferDataKind of
TM_FIELD: begin
address := Pointer(self) + offset;
boolean(address^) := value;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
ProcedureWriteIndexedValueOfBoolean(method)(pinfo^.index, value);
exit;
end;
ProcedureWriteValueOfBoolean(method)(value);
end;
end;
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
procedure TObjectExtended.writePropertyOfLong(const name: AnsiString; const value: long);
type
ProcedureWriteIndexedValueOfUByte = procedure(index: int; value: system.UInt8) of object;
ProcedureWriteIndexedValueOfUShort = procedure(index: int; value: system.UInt16) of object;
ProcedureWriteIndexedValueOfUInt = procedure(index: int; value: system.UInt32) of object;
ProcedureWriteIndexedValueOfByte = procedure(index: int; value: byte) of object;
ProcedureWriteIndexedValueOfShort = procedure(index: int; value: short) of object;
ProcedureWriteIndexedValueOfInt = procedure(index: int; value: int) of object;
ProcedureWriteIndexedValueOfLong = procedure(index: int; value: long) of object;
ProcedureWriteValueOfUByte = procedure(value: system.UInt8) of object;
ProcedureWriteValueOfUShort = procedure(value: system.UInt16) of object;
ProcedureWriteValueOfUInt = procedure(value: system.UInt32) of object;
ProcedureWriteValueOfByte = procedure(value: byte) of object;
ProcedureWriteValueOfShort = procedure(value: short) of object;
ProcedureWriteValueOfInt = procedure(value: int) of object;
ProcedureWriteValueOfLong = procedure(value: long) of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(pinfo^.propType);
case propertyTypeKind of
Lang.TYPE_CHAR, Lang.TYPE_BYTE, Lang.TYPE_SHORT, Lang.TYPE_INT, Lang.TYPE_LONG, Lang.TYPE_UCHAR, Lang.TYPE_UBYTE, Lang.TYPE_USHORT, Lang.TYPE_UINT, Lang.TYPE_ULONG: begin
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := (transferDataKind shr 2) and $03;
case transferDataKind of
TM_FIELD: begin
address := Pointer(self) + offset;
case propertyTypeKind of
Lang.TYPE_BYTE, Lang.TYPE_UBYTE, Lang.TYPE_CHAR:
byte(address^) := byte(value);
Lang.TYPE_SHORT, Lang.TYPE_USHORT, Lang.TYPE_UCHAR:
short(address^) := short(value);
Lang.TYPE_INT, Lang.TYPE_UINT:
int(address^) := int(value);
else
long(address^) := value;
end;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
case propertyTypeKind of
Lang.TYPE_UBYTE, Lang.TYPE_CHAR:
ProcedureWriteIndexedValueOfUByte(method)(pinfo^.index, system.UInt8(value));
Lang.TYPE_USHORT, Lang.TYPE_UCHAR:
ProcedureWriteIndexedValueOfUShort(method)(pinfo^.index, system.UInt16(value));
Lang.TYPE_UINT:
ProcedureWriteIndexedValueOfUInt(method)(pinfo^.index, system.UInt32(value));
Lang.TYPE_BYTE:
ProcedureWriteIndexedValueOfByte(method)(pinfo^.index, byte(value));
Lang.TYPE_SHORT:
ProcedureWriteIndexedValueOfShort(method)(pinfo^.index, short(value));
Lang.TYPE_INT:
ProcedureWriteIndexedValueOfInt(method)(pinfo^.index, int(value));
else
ProcedureWriteIndexedValueOfLong(method)(pinfo^.index, value);
end;
exit;
end;
case propertyTypeKind of
Lang.TYPE_UBYTE, Lang.TYPE_CHAR:
ProcedureWriteValueOfUByte(method)(system.UInt8(value));
Lang.TYPE_USHORT, Lang.TYPE_UCHAR:
ProcedureWriteValueOfUShort(method)(system.UInt16(value));
Lang.TYPE_UINT:
ProcedureWriteValueOfUInt(method)(system.UInt32(value));
Lang.TYPE_BYTE:
ProcedureWriteValueOfByte(method)(byte(value));
Lang.TYPE_SHORT:
ProcedureWriteValueOfShort(method)(short(value));
Lang.TYPE_INT:
ProcedureWriteValueOfInt(method)(int(value));
else
ProcedureWriteValueOfLong(method)(value);
end;
end;
end;
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
procedure TObjectExtended.writePropertyOfDouble(const name: AnsiString; const value: double);
type
ProcedureWriteIndexedValueOfFloat = procedure(index: int; value: float) of object;
ProcedureWriteIndexedValueOfDouble = procedure(index: int; value: double) of object;
ProcedureWriteValueOfFloat = procedure(value: float) of object;
ProcedureWriteValueOfDouble = procedure(value: double) of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(pinfo^.propType);
case propertyTypeKind of
Lang.TYPE_FLOAT, Lang.TYPE_DOUBLE: begin
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := (transferDataKind shr 2) and $03;
case transferDataKind of
TM_FIELD: begin
address := Pointer(self) + offset;
case propertyTypeKind of
Lang.TYPE_FLOAT:
float(address^) := CoDouble.toFloat(value);
else
double(address^) := value;
end;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
case propertyTypeKind of
Lang.TYPE_FLOAT:
ProcedureWriteIndexedValueOfFloat(method)(pinfo^.index, CoDouble.toFloat(value));
else
ProcedureWriteIndexedValueOfDouble(method)(pinfo^.index, value);
end;
exit;
end;
case propertyTypeKind of
Lang.TYPE_FLOAT:
ProcedureWriteValueOfFloat(method)(CoDouble.toFloat(value));
else
ProcedureWriteValueOfDouble(method)(value);
end;
end;
end;
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
procedure TObjectExtended.writePropertyOfAnsiString(const name: AnsiString; const value: AnsiString);
type
ProcedureWriteIndexedValueOfAnsiString = procedure(index: int; value: AnsiString) of object;
ProcedureWriteValueOfAnsiString = procedure(value: AnsiString) of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(pinfo^.propType);
case propertyTypeKind of
Lang.TYPE_ANSISTRING: begin
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := (transferDataKind shr 2) and $03;
case transferDataKind of
TM_FIELD: begin
address := Pointer(self) + offset;
AnsiString(address^) := value;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
ProcedureWriteIndexedValueOfAnsiString(method)(pinfo^.index, value);
exit;
end;
ProcedureWriteValueOfAnsiString(method)(value);
end;
end;
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
procedure TObjectExtended.writePropertyOfUnicodeString(const name: AnsiString; const value: UnicodeString);
type
ProcedureWriteIndexedValueOfUnicodeString = procedure(index: int; value: UnicodeString) of object;
ProcedureWriteValueOfUnicodeString = procedure(value: UnicodeString) of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(pinfo^.propType);
case propertyTypeKind of
Lang.TYPE_UNICODESTRING: begin
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := (transferDataKind shr 2) and $03;
case transferDataKind of
TM_FIELD: begin
address := Pointer(self) + offset;
UnicodeString(address^) := value;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
ProcedureWriteIndexedValueOfUnicodeString(method)(pinfo^.index, value);
exit;
end;
ProcedureWriteValueOfUnicodeString(method)(value);
end;
end;
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
procedure TObjectExtended.writePropertyOfObject(const name: AnsiString; const value: TObject);
type
ProcedureWriteIndexedValueOfObject = procedure(index: int; value: TObject) of object;
ProcedureWriteValueOfObject = procedure(value: TObject) of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
propertyTypeInfo: PTypeInfo;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeInfo := pinfo^.propType;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(propertyTypeInfo);
case propertyTypeKind of
Lang.TYPE_CLASS: begin
if (value <> nil) and not (ClassTypeInformation.create(propertyTypeInfo) as &Class).isAssignableFrom(value.getClass()) then begin
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := (transferDataKind shr 2) and $03;
case transferDataKind of
TM_FIELD: begin
address := Pointer(self) + offset;
TObject(address^) := value;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
ProcedureWriteIndexedValueOfObject(method)(pinfo^.index, value);
exit;
end;
ProcedureWriteValueOfObject(method)(value);
end;
end;
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
procedure TObjectExtended.writePropertyOfSimple(const name: AnsiString; const value: ISimple);
type
ProcedureWriteIndexedValueOfInterface = procedure(index: int; value: ISimple) of object;
ProcedureWriteValueOfInterface = procedure(value: ISimple) of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
propertyTypeInfo: PTypeInfo;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
vtemp: ISimple;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeInfo := pinfo^.propType;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(propertyTypeInfo);
case propertyTypeKind of
Lang.TYPE_INTERFACE_RAW: begin
vtemp := nil;
if (value <> nil) and (value.queryInterface(getTypeData(propertyTypeInfo)^.guid, vtemp) <> system.S_OK) then begin
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := (transferDataKind shr 2) and $03;
case transferDataKind of
TM_FIELD: begin
address := Pointer(self) + offset;
ISimple(address^) := vtemp;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
ProcedureWriteIndexedValueOfInterface(method)(pinfo^.index, vtemp);
exit;
end;
ProcedureWriteValueOfInterface(method)(vtemp);
end;
end;
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
procedure TObjectExtended.writePropertyOfUnknown(const name: AnsiString; const value: IUnknown);
type
ProcedureWriteIndexedValueOfInterface = procedure(index: int; value: IUnknown) of object;
ProcedureWriteValueOfInterface = procedure(value: IUnknown) of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
propertyTypeInfo: PTypeInfo;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
vtemp: IUnknown;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeInfo := pinfo^.propType;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(propertyTypeInfo);
case propertyTypeKind of
Lang.TYPE_INTERFACE_RC: begin
vtemp := nil;
if (value <> nil) and (value.queryInterface(getTypeData(propertyTypeInfo)^.guid, vtemp) <> system.S_OK) then begin
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := (transferDataKind shr 2) and $03;
case transferDataKind of
TM_FIELD: begin
address := Pointer(self) + offset;
IUnknown(address^) := vtemp;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
ProcedureWriteIndexedValueOfInterface(method)(pinfo^.index, vtemp);
exit;
end;
ProcedureWriteValueOfInterface(method)(vtemp);
end;
end;
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
function TObjectExtended.isStoredProperty(const name: AnsiString): boolean;
type
FunctionIsStoredIndexed = function(index: int): boolean of object;
FunctionIsStoredVoid = function(): boolean of object;
var
isIndexed: boolean;
transferDataKind: int;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := (transferDataKind shr 4) and $03;
case transferDataKind of
TM_FIELD: begin
access := pinfo^.storedProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
address := Pointer(self) + offset;
end;
TM_CONST: begin
address := @(pinfo^.storedProc);
end;
else
access := pinfo^.storedProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
result := FunctionIsStoredIndexed(method)(pinfo^.index);
exit;
end;
result := FunctionIsStoredVoid(method)();
exit;
end;
result := byte(address^) <> 0;
end;
function TObjectExtended.readPropertyOfBoolean(const name: AnsiString): boolean;
type
FunctionReadIndexedValueOfBoolean = function(index: int): boolean of object;
FunctionReadValueOfBoolean = function(): boolean of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(pinfo^.propType);
case propertyTypeKind of
Lang.TYPE_BOOLEAN: begin
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := transferDataKind and $03;
case transferDataKind of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
address := Pointer(self) + offset;
end;
TM_CONST: begin
address := @(pinfo^.getProc);
end;
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
result := FunctionReadIndexedValueOfBoolean(method)(pinfo^.index);
exit;
end;
result := FunctionReadValueOfBoolean(method)();
exit;
end;
result := byte(address^) <> 0;
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
function TObjectExtended.readPropertyOfLong(const name: AnsiString): long;
type
FunctionReadIndexedValueOfUByte = function(index: int): system.UInt8 of object;
FunctionReadIndexedValueOfUShort = function(index: int): system.UInt16 of object;
FunctionReadIndexedValueOfUInt = function(index: int): system.UInt32 of object;
FunctionReadIndexedValueOfByte = function(index: int): byte of object;
FunctionReadIndexedValueOfShort = function(index: int): short of object;
FunctionReadIndexedValueOfInt = function(index: int): int of object;
FunctionReadIndexedValueOfLong = function(index: int): long of object;
FunctionReadValueOfUByte = function(): system.UInt8 of object;
FunctionReadValueOfUShort = function(): system.UInt16 of object;
FunctionReadValueOfUInt = function(): system.UInt32 of object;
FunctionReadValueOfByte = function(): byte of object;
FunctionReadValueOfShort = function(): short of object;
FunctionReadValueOfInt = function(): int of object;
FunctionReadValueOfLong = function(): long of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(pinfo^.propType);
case propertyTypeKind of
Lang.TYPE_CHAR, Lang.TYPE_BYTE, Lang.TYPE_SHORT, Lang.TYPE_INT, Lang.TYPE_LONG, Lang.TYPE_UCHAR, Lang.TYPE_UBYTE, Lang.TYPE_USHORT, Lang.TYPE_UINT, Lang.TYPE_ULONG: begin
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := transferDataKind and $03;
case transferDataKind of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
address := Pointer(self) + offset;
end;
TM_CONST: begin
address := @(pinfo^.getProc);
end;
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
case propertyTypeKind of
Lang.TYPE_UBYTE, Lang.TYPE_CHAR:
result := FunctionReadIndexedValueOfUByte(method)(pinfo^.index);
Lang.TYPE_USHORT, Lang.TYPE_UCHAR:
result := FunctionReadIndexedValueOfUShort(method)(pinfo^.index);
Lang.TYPE_UINT:
result := FunctionReadIndexedValueOfUInt(method)(pinfo^.index);
Lang.TYPE_BYTE:
result := FunctionReadIndexedValueOfByte(method)(pinfo^.index);
Lang.TYPE_SHORT:
result := FunctionReadIndexedValueOfShort(method)(pinfo^.index);
Lang.TYPE_INT:
result := FunctionReadIndexedValueOfInt(method)(pinfo^.index);
else
result := FunctionReadIndexedValueOfLong(method)(pinfo^.index);
end;
exit;
end;
case propertyTypeKind of
Lang.TYPE_UBYTE, Lang.TYPE_CHAR:
result := FunctionReadValueOfUByte(method)();
Lang.TYPE_USHORT, Lang.TYPE_UCHAR:
result := FunctionReadValueOfUShort(method)();
Lang.TYPE_UINT:
result := FunctionReadValueOfUInt(method)();
Lang.TYPE_BYTE:
result := FunctionReadValueOfByte(method)();
Lang.TYPE_SHORT:
result := FunctionReadValueOfShort(method)();
Lang.TYPE_INT:
result := FunctionReadValueOfInt(method)();
else
result := FunctionReadValueOfLong(method)();
end;
exit;
end;
case propertyTypeKind of
Lang.TYPE_UBYTE, Lang.TYPE_CHAR:
result := system.UInt8(address^);
Lang.TYPE_USHORT, Lang.TYPE_UCHAR:
result := system.UInt16(address^);
Lang.TYPE_UINT:
result := system.UInt32(address^);
Lang.TYPE_BYTE:
result := byte(address^);
Lang.TYPE_SHORT:
result := short(address^);
Lang.TYPE_INT:
result := int(address^);
else
result := long(address^);
end;
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
function TObjectExtended.readPropertyOfDouble(const name: AnsiString): double;
type
FunctionReadIndexedValueOfFloat = function(index: int): float of object;
FunctionReadIndexedValueOfDouble = function(index: int): double of object;
FunctionReadValueOfFloat = function(): float of object;
FunctionReadValueOfDouble = function(): double of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(pinfo^.propType);
case propertyTypeKind of
Lang.TYPE_FLOAT, Lang.TYPE_DOUBLE: begin
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := transferDataKind and $03;
case transferDataKind of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
address := Pointer(self) + offset;
end;
TM_CONST: begin
address := @(pinfo^.getProc);
end;
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
case propertyTypeKind of
Lang.TYPE_FLOAT:
result := FunctionReadIndexedValueOfFloat(method)(pinfo^.index);
else
result := FunctionReadIndexedValueOfDouble(method)(pinfo^.index);
end;
exit;
end;
case propertyTypeKind of
Lang.TYPE_FLOAT:
result := FunctionReadValueOfFloat(method)();
else
result := FunctionReadValueOfDouble(method)();
end;
exit;
end;
case propertyTypeKind of
Lang.TYPE_FLOAT:
result := float(address^);
else
result := double(address^);
end;
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
function TObjectExtended.readPropertyOfAnsiString(const name: AnsiString): AnsiString;
type
FunctionReadIndexedValueOfAnsiString = function(index: int): AnsiString of object;
FunctionReadValueOfAnsiString = function(): AnsiString of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(pinfo^.propType);
case propertyTypeKind of
Lang.TYPE_ANSISTRING: begin
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := transferDataKind and $03;
case transferDataKind of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
address := Pointer(self) + offset;
end;
TM_CONST: begin
address := @(pinfo^.getProc);
end;
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
result := FunctionReadIndexedValueOfAnsiString(method)(pinfo^.index);
exit;
end;
result := FunctionReadValueOfAnsiString(method)();
exit;
end;
result := AnsiString(address^);
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
function TObjectExtended.readPropertyOfUnicodeString(const name: AnsiString): UnicodeString;
type
FunctionReadIndexedValueOfUnicodeString = function(index: int): UnicodeString of object;
FunctionReadValueOfUnicodeString = function(): UnicodeString of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(pinfo^.propType);
case propertyTypeKind of
Lang.TYPE_UNICODESTRING: begin
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := transferDataKind and $03;
case transferDataKind of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
address := Pointer(self) + offset;
end;
TM_CONST: begin
address := @(pinfo^.getProc);
end;
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
result := FunctionReadIndexedValueOfUnicodeString(method)(pinfo^.index);
exit;
end;
result := FunctionReadValueOfUnicodeString(method)();
exit;
end;
result := UnicodeString(address^);
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
function TObjectExtended.readPropertyOfObject(const name: AnsiString): TObject;
type
FunctionReadIndexedValueOfObject = function(index: int): TObject of object;
FunctionReadValueOfObject = function(): TObject of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(pinfo^.propType);
case propertyTypeKind of
Lang.TYPE_CLASS: begin
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := transferDataKind and $03;
case transferDataKind of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
address := Pointer(self) + offset;
end;
TM_CONST: begin
address := @(pinfo^.getProc);
end;
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
result := FunctionReadIndexedValueOfObject(method)(pinfo^.index);
exit;
end;
result := FunctionReadValueOfObject(method)();
exit;
end;
result := TObject(address^);
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
function TObjectExtended.readPropertyOfSimple(const name: AnsiString): ISimple;
type
FunctionReadIndexedValueOfInterface = function(index: int): ISimple of object;
FunctionReadValueOfInterface = function(): ISimple of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(pinfo^.propType);
case propertyTypeKind of
Lang.TYPE_INTERFACE_RAW: begin
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := transferDataKind and $03;
case transferDataKind of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
address := Pointer(self) + offset;
end;
TM_CONST: begin
address := @(pinfo^.getProc);
end;
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
result := FunctionReadIndexedValueOfInterface(method)(pinfo^.index);
exit;
end;
result := FunctionReadValueOfInterface(method)();
exit;
end;
result := ISimple(address^);
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
function TObjectExtended.readPropertyOfUnknown(const name: AnsiString): IUnknown;
type
FunctionReadIndexedValueOfInterface = function(index: int): IUnknown of object;
FunctionReadValueOfInterface = function(): IUnknown of object;
var
isIndexed: boolean;
transferDataKind: int;
propertyTypeKind: int;
offset: long;
access: CodePointer absolute offset;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'not-found.property'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
propertyTypeKind := ClassTypeInformation.typeInfoToLangType(pinfo^.propType);
case propertyTypeKind of
Lang.TYPE_INTERFACE_RC: begin
transferDataKind := pinfo^.propProcs;
isIndexed := (transferDataKind and $40) <> 0;
transferDataKind := transferDataKind and $03;
case transferDataKind of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
address := Pointer(self) + offset;
end;
TM_CONST: begin
address := @(pinfo^.getProc);
end;
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.access'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
if transferDataKind = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(classType()) + offset)^);
end;
method.data := self;
if isIndexed then begin
result := FunctionReadIndexedValueOfInterface(method)(pinfo^.index);
exit;
end;
result := FunctionReadValueOfInterface(method)();
exit;
end;
result := IUnknown(address^);
end;
else
raise IllegalPropertyTypeException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'property-operation.type'), [
CoAnsiString.create(name), CoAnsiString.create(getClass().getCanonicalName())
]));
end;
end;
function TObjectExtended.getClass(): &Class;
begin
result := ClassTypeInformation.create(classType());
end;
{%endregion}
{%region ISimpleExtended}
function ISimpleExtended.getClass(): &Class;
var
asObject: TObject;
begin
if queryInterface(IObjectInstance, asObject) <> system.S_OK then begin
result := InterfaceTypeInformation.create(PTypeInfo(typeInfo(ISimple)));
exit;
end;
result := ClassTypeInformation.create(asObject.classType());
end;
{%endregion}
{%region IUnknownExtended}
function IUnknownExtended.getClass(): &Class;
var
asObject: TObject;
begin
if queryInterface(IObjectInstance, asObject) <> system.S_OK then begin
result := InterfaceTypeInformation.create(PTypeInfo(typeInfo(IUnknown)));
exit;
end;
result := ClassTypeInformation.create(asObject.classType());
end;
{%endregion}
{%region AnsiStringExtended}
class function AnsiStringExtended.create(length: int): AnsiString;
begin
if length < 0 then length := 0;
result := '';
setLength(result, length);
end;
class function AnsiStringExtended.create(const src: byte_Array1d): AnsiString;
var
len: int;
begin
len := system.length(src);
result := '';
setLength(result, len);
&Array.copyRaw(src[0], result[1], len);
end;
class function AnsiStringExtended.create(const src: char_Array1d): AnsiString;
var
len: int;
begin
len := system.length(src);
result := '';
setLength(result, len);
&Array.copyRaw(src[0], result[1], len);
end;
class function AnsiStringExtended.create(const src: byte_Array1d; offset, length: int): AnsiString;
begin
&Array.checkBounds(src, offset, length);
result := '';
setLength(result, length);
&Array.copyRaw(src[offset], result[1], length);
end;
class function AnsiStringExtended.create(const src: char_Array1d; offset, length: int): AnsiString;
begin
&Array.checkBounds(src, offset, length);
result := '';
setLength(result, length);
&Array.copyRaw(src[offset], result[1], length);
end;
class function AnsiStringExtended.create(const charCodes: int_Array1d; offset, length: int): AnsiString;
var
idx: int;
cap: int;
len: int;
ccd: int;
buf: byte_Array1d;
begin
&Array.checkBounds(charCodes, offset, length);
len := 0;
cap := int(CoLong.min(long(length) * 6, CoInt.MAX_VALUE));
buf := &Array.newByte1d(cap);
for idx := offset to offset + length - 1 do begin
ccd := charCodes[idx];
if (ccd >= $00000001) and (ccd < $00000080) then begin
if len >= cap then break;
buf[len] := byte(ccd);
inc(len);
end else
if (ccd >= $00000000) and (ccd < $00000800) then begin
if len >= cap - 1 then break;
buf[len] := byte($c0 + (ccd shr 6));
buf[len + 1] := byte($80 + (ccd and $3f));
inc(len, 2);
end else
if (ccd >= $00000800) and (ccd < $00010000) then begin
if len >= cap - 2 then break;
buf[len] := byte($e0 + (ccd shr 12));
buf[len + 1] := byte($80 + ((ccd shr 6) and $3f));
buf[len + 2] := byte($80 + (ccd and $3f));
inc(len, 3);
end else
if (ccd >= $00010000) and (ccd < $00200000) then begin
if len >= cap - 3 then break;
buf[len] := byte($f0 + (ccd shr 18));
buf[len + 1] := byte($80 + ((ccd shr 12) and $3f));
buf[len + 2] := byte($80 + ((ccd shr 6) and $3f));
buf[len + 3] := byte($80 + (ccd and $3f));
inc(len, 4);
end else
if (ccd >= $00200000) and (ccd < $04000000) then begin
if len >= cap - 4 then break;
buf[len] := byte($f8 + (ccd shr 24));
buf[len + 1] := byte($80 + ((ccd shr 18) and $3f));
buf[len + 2] := byte($80 + ((ccd shr 12) and $3f));
buf[len + 3] := byte($80 + ((ccd shr 6) and $3f));
buf[len + 4] := byte($80 + (ccd and $3f));
inc(len, 5);
end else begin
if len >= cap - 5 then break;
buf[len] := byte($fc + (ccd shr 30));
buf[len + 1] := byte($80 + ((ccd shr 24) and $3f));
buf[len + 2] := byte($80 + ((ccd shr 18) and $3f));
buf[len + 3] := byte($80 + ((ccd shr 12) and $3f));
buf[len + 4] := byte($80 + ((ccd shr 6) and $3f));
buf[len + 5] := byte($80 + (ccd and $3f));
inc(len, 6);
end;
end;
result := create(buf, 0, len);
end;
class function AnsiStringExtended.format(const form: AnsiString; const data: array of Value): AnsiString;
var
isReal: boolean;
isString: boolean;
isExpForm: boolean;
significandAll: boolean;
significandSign: boolean;
orderSign: boolean;
leadZeroOutput: boolean;
formChar: char;
formDigit: int;
beginIndex: int;
endIndex: int;
formIndex: int;
dataIndex: int;
formLength: int;
dataLimit: int absolute high(data);
significandDigits: int;
orderDigits: int;
leadZeroWidth: int;
fieldWidth: int;
formattedWidth: int;
count: int;
number: long;
formattedInstance: AnsiString;
formInstance: AnsiString absolute form;
dataArray: array [0..0] of Value absolute data;
dataComponent: Value;
label
break_label0,
continue_label0;
begin
formLength := formInstance.length;
if formLength <= 0 then begin
result := '';
exit;
end;
result := '';
beginIndex := 1;
endIndex := formInstance.indexOf('%');
while endIndex - 1 >= 0 do begin
result := result + formInstance.substring(beginIndex, endIndex);
beginIndex := endIndex;
formIndex := beginIndex + 1;
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if formChar = '%' then begin
endIndex := formIndex + 1;
result := result + '%';
goto continue_label0;
end;
if (formChar < '0') or (formChar > '9') then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
dataIndex := int(formChar) - int('0');
repeat
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if (formChar < '0') or (formChar > '9') then break;
formDigit := int(formChar) - int('0');
if dataIndex > CoInt.MAX_VALUE div 10 then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
dataIndex := dataIndex * 10;
if dataIndex > CoInt.MAX_VALUE - formDigit then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
dataIndex := dataIndex + formDigit;
until false;
isReal := false;
isString := true;
isExpForm := false;
significandAll := false;
significandSign := false;
orderSign := true;
leadZeroOutput := false;
significandDigits := 1;
orderDigits := 0;
leadZeroWidth := 0;
if formChar = '#' then begin
isString := false;
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if formChar = '+' then begin
significandSign := true;
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
end;
if formChar = '0' then begin
leadZeroOutput := true;
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if (formChar < '0') or (formChar > '9') then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
leadZeroWidth := int(formChar) - int('0');
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if (formChar >= '0') and (formChar <= '9') then begin
leadZeroWidth := (leadZeroWidth * 10) + (int(formChar) - int('0'));
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
end;
end else begin
if formChar <> '1' then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if formChar = '.' then begin
isReal := true;
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if (formChar < '0') or (formChar > '9') then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
significandDigits := int(formChar) - int('0');
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if (formChar >= '0') and (formChar <= '9') then begin
significandDigits := (significandDigits * 10) + (int(formChar) - int('0'));
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
end;
if significandDigits < 1 then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
inc(significandDigits);
if (formChar = 'A') or (formChar = 'a') then begin
significandAll := true;
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
end;
end;
isExpForm := formChar = 'E';
if isExpForm or (formChar = 'e') then begin
isReal := true;
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if formChar <> '+' then begin
orderSign := false;
end else begin
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
end;
if (formChar < '0') or (formChar > '4') then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
orderDigits := int(formChar) - int('0');
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
end;
end;
end;
fieldWidth := 0;
if formChar = ':' then begin
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if (formChar < '0') or (formChar > '9') then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
fieldWidth := int(formChar) - int('0');
repeat
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if (formChar < '0') or (formChar > '9') then break;
formDigit := int(formChar) - int('0');
fieldWidth := fieldWidth * 10;
if fieldWidth > 1024 - formDigit then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
fieldWidth := fieldWidth + formDigit;
until false;
end;
if formChar <> '%' then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
if (dataIndex < 0) or (dataIndex > dataLimit) then begin
raise ArrayIndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.array-index'));
end;
dataComponent := dataArray[dataIndex];
if dataComponent = nil then begin
raise NullPointerException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'null-pointer'));
end;
if isString then begin
formattedInstance := dataComponent.toString();
end else
if isReal then begin
if significandDigits <= 1 then significandDigits := RealRepresenter.MAX_SIGNIFICAND_DIGITS;
formattedInstance := CoReal.toString(dataComponent.asReal(), significandDigits, orderDigits, significandAll, orderDigits > 0, isExpForm, significandSign, orderSign);
end else begin
number := dataComponent.asLong();
if leadZeroOutput then begin
formattedInstance := CoLong.toLeadZeroString(number, leadZeroWidth);
end else begin
formattedInstance := CoLong.toString(number);
end;
if significandSign and (number >= 0) then formattedInstance := '+' + formattedInstance;
end;
formattedWidth := formattedInstance.length;
if fieldWidth > formattedWidth then for count := fieldWidth - formattedWidth - 1 downto 0 do result := result + ' ';
endIndex := formIndex + 1;
result := result + formattedInstance;
continue_label0:
beginIndex := endIndex;
endIndex := formInstance.indexOf('%', beginIndex);
end;
break_label0:
result := result + formInstance.substring(beginIndex);
end;
function AnsiStringExtended.getLength(): int;
begin
result := system.length(self);
end;
procedure AnsiStringExtended.getChars(beginIndex, endIndex: int; const dst: char_Array1d; offset: int);
var
thisLength: int;
begin
dec(endIndex);
dec(beginIndex);
thisLength := length;
if ((beginIndex or endIndex) < 0) or (beginIndex > thisLength) or (endIndex > thisLength) or (beginIndex > endIndex) then begin
raise StringIndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.string-index'));
end;
thisLength := endIndex - beginIndex;
&Array.checkBounds(dst, offset, thisLength);
&Array.copyRaw(self[beginIndex + 1], dst[offset], thisLength);
end;
function AnsiStringExtended.startsWith(const prefix: AnsiString; position: int): boolean;
var
anotLength: int;
begin
dec(position);
anotLength := prefix.length;
if (position < 0) or (position > length - anotLength) then begin
result := false;
exit;
end;
result := (anotLength <= 0) or (&Array.compfne(self[position + 1], prefix[1], 0, anotLength) = &Array.NOT_FOUND);
end;
function AnsiStringExtended.endsWith(const suffix: AnsiString): boolean;
var
position: int;
anotLength: int;
begin
anotLength := suffix.length;
position := length - anotLength;
if position < 0 then begin
result := false;
exit;
end;
result := (anotLength <= 0) or (&Array.compfne(self[position + 1], suffix[1], 0, anotLength) = &Array.NOT_FOUND);
end;
function AnsiStringExtended.indexOf(const prefix: AnsiString; startFromIndex: int): int;
var
anotLength: int;
thisLength: int;
thisOffset: int;
firstCharValue: long;
begin
dec(startFromIndex);
anotLength := prefix.length;
thisLength := length - anotLength;
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex > thisLength then begin
result := 0;
exit;
end;
if anotLength <= 0 then begin
result := startFromIndex + 1;
exit;
end;
dec(anotLength);
inc(thisLength);
firstCharValue := long(prefix[1]);
repeat
thisOffset := &Array.findfeq(self[startFromIndex + 1], 0, thisLength - startFromIndex, firstCharValue);
if thisOffset = &Array.NOT_FOUND then break;
inc(startFromIndex, thisOffset);
if (anotLength <= 0) or (&Array.compfne(self[startFromIndex + 2], prefix[2], 0, anotLength) = &Array.NOT_FOUND) then begin
result := startFromIndex + 1;
exit;
end;
inc(startFromIndex);
until startFromIndex >= thisLength;
result := 0;
end;
function AnsiStringExtended.lastIndexOf(const prefix: AnsiString; startFromIndex: int): int;
var
anotLength: int;
thisLength: int;
thisOffset: int;
firstCharValue: long;
begin
dec(startFromIndex);
anotLength := prefix.length;
thisLength := length - anotLength;
if startFromIndex > thisLength then begin
startFromIndex := thisLength;
end;
if startFromIndex < 0 then begin
result := 0;
exit;
end;
if anotLength <= 0 then begin
result := startFromIndex + 1;
exit;
end;
dec(anotLength);
firstCharValue := long(prefix[1]);
repeat
thisOffset := &Array.findbeq(self[startFromIndex + 1], 0, startFromIndex + 1, firstCharValue);
if thisOffset = &Array.NOT_FOUND then break;
inc(startFromIndex, thisOffset);
if (anotLength <= 0) or (&Array.compfne(self[startFromIndex + 2], prefix[2], 0, anotLength) = &Array.NOT_FOUND) then begin
result := startFromIndex + 1;
exit;
end;
dec(startFromIndex);
until startFromIndex < 0;
result := 0;
end;
function AnsiStringExtended.replaceAll(oldCharacter, newCharacter: char): AnsiString;
var
chi: int;
chj: int;
thisOffset: int;
thisLength: int;
oldCharValue: long;
begin
thisLength := length;
if (thisLength <= 0) or (oldCharacter = newCharacter) then begin
result := self;
exit;
end;
oldCharValue := long(oldCharacter);
thisOffset := &Array.findfeq(self[1], 0, thisLength, oldCharValue);
if thisOffset = &Array.NOT_FOUND then begin
result := self;
exit;
end;
result := create(thisLength);
chi := 0;
chj := thisOffset;
repeat
&Array.copyRaw(self[chi + 1], result[chi + 1], chj - chi);
if chj >= thisLength then break;
result[chj + 1] := newCharacter;
chi := chj + 1;
if chi >= thisLength then break;
thisOffset := &Array.findfeq(self[chi + 1], 0, thisLength - chi, oldCharValue);
if thisOffset = &Array.NOT_FOUND then begin
chj := thisLength;
continue;
end;
chj := chi + thisOffset;
until false;
end;
function AnsiStringExtended.copy(): AnsiString;
var
thisLength: int;
begin
thisLength := length;
result := create(thisLength);
&Array.copyRaw(self[1], result[1], thisLength);
end;
function AnsiStringExtended.copy(beginIndex: int): AnsiString;
var
thisLength: int;
rsltLength: int;
begin
dec(beginIndex);
thisLength := length;
if (beginIndex < 0) or (beginIndex > thisLength) then begin
raise StringIndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.string-index'));
end;
rsltLength := thisLength - beginIndex;
result := create(rsltLength);
&Array.copyRaw(self[beginIndex + 1], result[1], rsltLength);
end;
function AnsiStringExtended.copy(beginIndex, endIndex: int): AnsiString;
var
thisLength: int;
rsltLength: int;
begin
dec(endIndex);
dec(beginIndex);
thisLength := length;
if ((beginIndex or endIndex) < 0) or (beginIndex > thisLength) or (endIndex > thisLength) or (beginIndex > endIndex) then begin
raise StringIndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.string-index'));
end;
rsltLength := endIndex - beginIndex;
result := create(rsltLength);
&Array.copyRaw(self[beginIndex + 1], result[1], rsltLength);
end;
function AnsiStringExtended.trim(): AnsiString;
var
chi: int;
chj: int;
endIndex: int;
thisLength: int;
rsltLength: int;
begin
thisLength := length;
if thisLength <= 0 then begin
result := '';
exit;
end;
chi := 0;
chj := thisLength - 1;
endIndex := chj;
while (chi <= chj) and (self[chi + 1] <= #$20) do begin
inc(chi);
end;
while (chi <= chj) and (self[chj + 1] <= #$20) do begin
dec(chj);
end;
if chi > chj then begin
result := '';
exit;
end;
if (chi = 0) and (chj = endIndex) then begin
result := self;
exit;
end;
rsltLength := chj - chi + 1;
result := create(rsltLength);
&Array.copyRaw(self[chi + 1], result[1], rsltLength);
end;
function AnsiStringExtended.substring(beginIndex: int): AnsiString;
var
thisLength: int;
rsltLength: int;
begin
dec(beginIndex);
thisLength := length;
if (beginIndex < 0) or (beginIndex > thisLength) then begin
raise StringIndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.string-index'));
end;
if beginIndex = thisLength then begin
result := '';
exit;
end;
if beginIndex = 0 then begin
result := self;
exit;
end;
rsltLength := thisLength - beginIndex;
result := create(rsltLength);
&Array.copyRaw(self[beginIndex + 1], result[1], rsltLength);
end;
function AnsiStringExtended.substring(beginIndex, endIndex: int): AnsiString;
var
thisLength: int;
rsltLength: int;
begin
dec(endIndex);
dec(beginIndex);
thisLength := length;
if ((beginIndex or endIndex) < 0) or (beginIndex > thisLength) or (endIndex > thisLength) or (beginIndex > endIndex) then begin
raise StringIndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.string-index'));
end;
if beginIndex = endIndex then begin
result := '';
exit;
end;
if beginIndex = endIndex - thisLength then begin
result := self;
exit;
end;
rsltLength := endIndex - beginIndex;
result := create(rsltLength);
&Array.copyRaw(self[beginIndex + 1], result[1], rsltLength);
end;
function AnsiStringExtended.toLowerCase(): AnsiString;
var
character: char;
thisLength: int;
idx: int;
label
break_label0;
begin
thisLength := length;
idx := 0;
begin
while idx < thisLength do begin
character := self[idx + 1];
if character <> CoChar.toLowerCase(character) then goto break_label0;
inc(idx);
end;
result := self;
exit;
end;
break_label0:
result := create(thisLength);
&Array.copyRaw(self[1], result[1], idx);
while idx < thisLength do begin
result[idx + 1] := CoChar.toLowerCase(self[idx + 1]);
inc(idx);
end;
end;
function AnsiStringExtended.toUpperCase(): AnsiString;
var
character: char;
thisLength: int;
idx: int;
label
break_label0;
begin
thisLength := length;
idx := 0;
begin
while idx < thisLength do begin
character := self[idx + 1];
if character <> CoChar.toUpperCase(character) then goto break_label0;
inc(idx);
end;
result := self;
exit;
end;
break_label0:
result := create(thisLength);
&Array.copyRaw(self[1], result[1], idx);
while idx < thisLength do begin
result[idx + 1] := CoChar.toUpperCase(self[idx + 1]);
inc(idx);
end;
end;
function AnsiStringExtended.toUTF16(): UnicodeString;
var
idx: int;
cap: int;
slen: int;
rlen: int;
code: int;
char1: int;
char2: int;
char3: int;
char4: int;
buf: short_Array1d;
begin
slen := length;
if slen <= 0 then begin
result := '';
exit;
end;
rlen := 0;
cap := int(CoLong.min(long(slen) shl 1, CoInt.MAX_VALUE));
buf := &Array.newShort1d(cap);
idx := 0;
while idx < slen do begin
char1 := int(self[idx + 1]);
inc(idx);
if (char1 >= $00) and (char1 < $80) then begin
if rlen >= cap then break;
buf[rlen] := short(char1);
inc(rlen);
end else
if (char1 >= $c0) and (char1 < $e0) then begin
if rlen >= cap then break;
char2 := 0;
if idx < slen then begin
char2 := int(self[idx + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(idx);
end;
end;
buf[rlen] := short(((char1 and $1f) shl 6) or (char2 and $3f));
inc(rlen);
end else
if (char1 >= $e0) and (char1 < $f0) then begin
char2 := 0;
char3 := 0;
if idx < slen then begin
char2 := int(self[idx + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(idx);
end;
end;
if idx < slen then begin
char3 := int(self[idx + 1]);
if (char3 and $c0) <> $80 then begin
char3 := 0;
end else begin
inc(idx);
end;
end;
code := ((char1 and $0f) shl 12) or ((char2 and $3f) shl 6) or (char3 and $3f);
if (code < $d800) or (code >= $e000) then begin
if rlen >= cap then break;
buf[rlen] := short(code);
inc(rlen);
end;
end else
if (char1 >= $f0) and (char1 < $f8) then begin
char2 := 0;
char3 := 0;
char4 := 0;
if idx < slen then begin
char2 := int(self[idx + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(idx);
end;
end;
if idx < slen then begin
char3 := int(self[idx + 1]);
if (char3 and $c0) <> $80 then begin
char3 := 0;
end else begin
inc(idx);
end;
end;
if idx < slen then begin
char4 := int(self[idx + 1]);
if (char4 and $c0) <> $80 then begin
char4 := 0;
end else begin
inc(idx);
end;
end;
code := ((char1 and $07) shl 18) or ((char2 and $3f) shl 12) or ((char3 and $3f) shl 6) or (char4 and $3f);
if (code < $00d800) or (code >= $00e000) and (code < $010000) then begin
if rlen >= cap then break;
buf[rlen] := short(code);
inc(rlen);
end else
if (code >= $010000) and (code < $110000) then begin
if rlen >= cap - 1 then break;
dec(code, $010000);
buf[rlen] := short($d800 + (code shr 10));
buf[rlen + 1] := short($dc00 + (code and $03ff));
inc(rlen, 2);
end;
end;
end;
result := UnicodeString.create(buf, 0, rlen);
end;
function AnsiStringExtended.toByteArray(): byte_Array1d;
var
thisLength: int;
begin
thisLength := length;
result := &Array.newByte1d(thisLength);
&Array.copyRaw(self[1], result[0], thisLength);
end;
function AnsiStringExtended.toCharArray(): char_Array1d;
var
thisLength: int;
begin
thisLength := length;
result := &Array.newChar1d(thisLength);
&Array.copyRaw(self[1], result[0], thisLength);
end;
function AnsiStringExtended.toCharCodes(): int_Array1d;
var
idx: int;
slen: int;
rlen: int;
char1: int;
char2: int;
char3: int;
char4: int;
char5: int;
char6: int;
buf: int_Array1d;
cpy: int_Array1d;
begin
slen := length;
if slen <= 0 then begin
result := &Array.newInt1d(0);
exit;
end;
rlen := 0;
buf := &Array.newInt1d(slen);
idx := 0;
while idx < slen do begin
char1 := int(self[idx + 1]);
inc(idx);
if (char1 >= $00) and (char1 < $80) then begin
buf[rlen] := char1;
inc(rlen);
end else
if (char1 >= $c0) and (char1 < $e0) then begin
char2 := 0;
if idx < slen then begin
char2 := int(self[idx + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(idx);
end;
end;
buf[rlen] := ((char1 and $1f) shl 6) or (char2 and $3f);
inc(rlen);
end else
if (char1 >= $e0) and (char1 < $f0) then begin
char2 := 0;
char3 := 0;
if idx < slen then begin
char2 := int(self[idx + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(idx);
end;
end;
if idx < slen then begin
char3 := int(self[idx + 1]);
if (char3 and $c0) <> $80 then begin
char3 := 0;
end else begin
inc(idx);
end;
end;
buf[rlen] := ((char1 and $0f) shl 12) or ((char2 and $3f) shl 6) or (char3 and $3f);
inc(rlen);
end else
if (char1 >= $f0) and (char1 < $f8) then begin
char2 := 0;
char3 := 0;
char4 := 0;
if idx < slen then begin
char2 := int(self[idx + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(idx);
end;
end;
if idx < slen then begin
char3 := int(self[idx + 1]);
if (char3 and $c0) <> $80 then begin
char3 := 0;
end else begin
inc(idx);
end;
end;
if idx < slen then begin
char4 := int(self[idx + 1]);
if (char4 and $c0) <> $80 then begin
char4 := 0;
end else begin
inc(idx);
end;
end;
buf[rlen] := ((char1 and $07) shl 18) or ((char2 and $3f) shl 12) or ((char3 and $3f) shl 6) or (char4 and $3f);
inc(rlen);
end else
if (char1 >= $f8) and (char1 < $fc) then begin
char2 := 0;
char3 := 0;
char4 := 0;
char5 := 0;
if idx < slen then begin
char2 := int(self[idx + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(idx);
end;
end;
if idx < slen then begin
char3 := int(self[idx + 1]);
if (char3 and $c0) <> $80 then begin
char3 := 0;
end else begin
inc(idx);
end;
end;
if idx < slen then begin
char4 := int(self[idx + 1]);
if (char4 and $c0) <> $80 then begin
char4 := 0;
end else begin
inc(idx);
end;
end;
if idx < slen then begin
char5 := int(self[idx + 1]);
if (char5 and $c0) <> $80 then begin
char5 := 0;
end else begin
inc(idx);
end;
end;
buf[rlen] := ((char1 and $03) shl 24) or ((char2 and $3f) shl 18) or ((char3 and $3f) shl 12) or ((char4 and $3f) shl 6) or (char5 and $3f);
inc(rlen);
end else
if char1 >= $fc then begin
char2 := 0;
char3 := 0;
char4 := 0;
char5 := 0;
char6 := 0;
if idx < slen then begin
char2 := int(self[idx + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(idx);
end;
end;
if idx < slen then begin
char3 := int(self[idx + 1]);
if (char3 and $c0) <> $80 then begin
char3 := 0;
end else begin
inc(idx);
end;
end;
if idx < slen then begin
char4 := int(self[idx + 1]);
if (char4 and $c0) <> $80 then begin
char4 := 0;
end else begin
inc(idx);
end;
end;
if idx < slen then begin
char5 := int(self[idx + 1]);
if (char5 and $c0) <> $80 then begin
char5 := 0;
end else begin
inc(idx);
end;
end;
if idx < slen then begin
char6 := int(self[idx + 1]);
if (char6 and $c0) <> $80 then begin
char6 := 0;
end else begin
inc(idx);
end;
end;
buf[rlen] := (char1 shl 30) or ((char2 and $3f) shl 24) or ((char3 and $3f) shl 18) or ((char4 and $3f) shl 12) or ((char5 and $3f) shl 6) or (char6 and $3f);
inc(rlen);
end;
end;
if slen = rlen then begin
result := buf;
exit;
end;
cpy := &Array.newInt1d(rlen);
&Array.copyPrimitives(buf, 0, cpy, 0, rlen);
result := cpy;
end;
function AnsiStringExtended.split(): AnsiString_Array1d;
var
findLimit: int;
endOffset0: int;
endOffset1: int;
beginIndex: int;
thisLength: int;
boundsLength: int;
substringLength: int;
substringInstance: AnsiString;
substringBounds: int2;
boundsData: int2_Array1d;
boundsCopy: int2_Array1d;
begin
thisLength := length;
boundsLength := 0;
boundsData := newInt2Array1d($0f);
beginIndex := 0;
while (beginIndex <= thisLength) and (beginIndex >= 0) do begin
if beginIndex >= thisLength then begin
endOffset0 := 0;
endOffset1 := 0;
end else begin
findLimit := thisLength - beginIndex;
endOffset0 := &Array.findfeq(self[beginIndex + 1], 0, findLimit, $0a);
endOffset1 := &Array.findfeq(self[beginIndex + 1], 0, findLimit, $0d);
if endOffset0 = &Array.NOT_FOUND then endOffset0 := findLimit;
if endOffset1 = &Array.NOT_FOUND then endOffset1 := findLimit;
end;
if endOffset0 >= endOffset1 then begin
endOffset0 := endOffset1;
end;
if boundsLength = system.length(boundsData) then begin
boundsCopy := newInt2Array1d((boundsLength shl 1) or 1);
&Array.copyRaw(boundsData[0], boundsCopy[0], boundsLength * sizeof(int2));
boundsData := boundsCopy;
end;
boundsData[boundsLength] := newInt2(beginIndex, endOffset0);
inc(boundsLength);
inc(beginIndex, endOffset0 + 1);
if (beginIndex < thisLength) and (self[beginIndex] = #$0d) and (self[beginIndex + 1] = #$0a) then inc(beginIndex);
end;
result := &Array.newAnsiString1d(boundsLength);
while boundsLength > 0 do begin
dec(boundsLength);
substringBounds := boundsData[boundsLength];
substringLength := substringBounds[1];
if substringLength <= 0 then begin
substringInstance := '';
end else
if substringLength >= thisLength then begin
substringInstance := self;
end else begin
substringInstance := create(substringLength);
&Array.copyRaw(self[substringBounds[0] + 1], substringInstance[1], substringLength);
end;
result[boundsLength] := substringInstance;
end;
end;
{%endregion}
{%region UnicodeStringExtended}
class function UnicodeStringExtended.create(length: int): UnicodeString;
begin
if length < 0 then length := 0;
result := '';
setLength(result, length);
end;
class function UnicodeStringExtended.create(const src: short_Array1d): UnicodeString;
var
len: int;
begin
len := system.length(src);
result := '';
setLength(result, len);
&Array.copyRaw(src[0], result[1], long(len) * sizeof(uchar));
end;
class function UnicodeStringExtended.create(const src: uchar_Array1d): UnicodeString;
var
len: int;
begin
len := system.length(src);
result := '';
setLength(result, len);
&Array.copyRaw(src[0], result[1], long(len) * sizeof(uchar));
end;
class function UnicodeStringExtended.create(const src: short_Array1d; offset, length: int): UnicodeString;
begin
&Array.checkBounds(src, offset, length);
result := '';
setLength(result, length);
&Array.copyRaw(src[offset], result[1], long(length) * sizeof(uchar));
end;
class function UnicodeStringExtended.create(const src: uchar_Array1d; offset, length: int): UnicodeString;
begin
&Array.checkBounds(src, offset, length);
result := '';
setLength(result, length);
&Array.copyRaw(src[offset], result[1], long(length) * sizeof(uchar));
end;
class function UnicodeStringExtended.create(const charCodes: int_Array1d; offset, length: int): UnicodeString;
var
idx: int;
cap: int;
len: int;
ccd: int;
buf: short_Array1d;
begin
&Array.checkBounds(charCodes, offset, length);
len := 0;
cap := int(CoLong.min(long(length) * 2, CoInt.MAX_VALUE));
buf := &Array.newShort1d(cap);
for idx := offset to offset + length - 1 do begin
ccd := charCodes[idx];
if (ccd >= $000000) and (ccd < $00d800) or (ccd >= $00e000) and (ccd < $010000) then begin
if len >= cap then break;
buf[len] := short(ccd);
inc(len);
end else
if (ccd >= $010000) and (ccd < $110000) then begin
if len >= cap - 1 then break;
dec(ccd, $010000);
buf[len] := short($d800 + (ccd shr 10));
buf[len + 1] := short($dc00 + (ccd and $03ff));
inc(len, 2);
end;
end;
result := create(buf, 0, len);
end;
class function UnicodeStringExtended.format(const form: UnicodeString; const data: array of Value): UnicodeString;
var
isReal: boolean;
isString: boolean;
isExpForm: boolean;
significandAll: boolean;
significandSign: boolean;
orderSign: boolean;
leadZeroOutput: boolean;
formChar: uchar;
formDigit: int;
beginIndex: int;
endIndex: int;
formIndex: int;
dataIndex: int;
formLength: int;
dataLimit: int absolute high(data);
significandDigits: int;
orderDigits: int;
leadZeroWidth: int;
fieldWidth: int;
formattedWidth: int;
count: int;
number: long;
formattedInstance: AnsiString;
formInstance: UnicodeString absolute form;
dataArray: array [0..0] of Value absolute data;
dataComponent: Value;
label
break_label0,
continue_label0;
begin
formLength := formInstance.length;
if formLength <= 0 then begin
result := '';
exit;
end;
result := '';
beginIndex := 1;
endIndex := formInstance.indexOf('%');
while endIndex - 1 >= 0 do begin
result := result + formInstance.substring(beginIndex, endIndex);
beginIndex := endIndex;
formIndex := beginIndex + 1;
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if formChar = '%' then begin
endIndex := formIndex + 1;
result := result + '%';
goto continue_label0;
end;
if (formChar < '0') or (formChar > '9') then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
dataIndex := int(formChar) - int('0');
repeat
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if (formChar < '0') or (formChar > '9') then break;
formDigit := int(formChar) - int('0');
if dataIndex > CoInt.MAX_VALUE div 10 then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
dataIndex := dataIndex * 10;
if dataIndex > CoInt.MAX_VALUE - formDigit then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
dataIndex := dataIndex + formDigit;
until false;
isReal := false;
isString := true;
isExpForm := false;
significandAll := false;
significandSign := false;
orderSign := true;
leadZeroOutput := false;
significandDigits := 1;
orderDigits := 0;
leadZeroWidth := 0;
if formChar = '#' then begin
isString := false;
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if formChar = '+' then begin
significandSign := true;
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
end;
if formChar = '0' then begin
leadZeroOutput := true;
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if (formChar < '0') or (formChar > '9') then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
leadZeroWidth := int(formChar) - int('0');
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if (formChar >= '0') and (formChar <= '9') then begin
leadZeroWidth := (leadZeroWidth * 10) + (int(formChar) - int('0'));
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
end;
end else begin
if formChar <> '1' then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if formChar = '.' then begin
isReal := true;
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if (formChar < '0') or (formChar > '9') then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
significandDigits := int(formChar) - int('0');
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if (formChar >= '0') and (formChar <= '9') then begin
significandDigits := (significandDigits * 10) + (int(formChar) - int('0'));
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
end;
if significandDigits < 1 then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
inc(significandDigits);
if (formChar = 'A') or (formChar = 'a') then begin
significandAll := true;
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
end;
end;
isExpForm := formChar = 'E';
if isExpForm or (formChar = 'e') then begin
isReal := true;
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if formChar <> '+' then begin
orderSign := false;
end else begin
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
end;
if (formChar < '0') or (formChar > '4') then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
orderDigits := int(formChar) - int('0');
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
end;
end;
end;
fieldWidth := 0;
if formChar = ':' then begin
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if (formChar < '0') or (formChar > '9') then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
fieldWidth := int(formChar) - int('0');
repeat
inc(formIndex);
if formIndex - 1 >= formLength then goto break_label0;
formChar := formInstance[formIndex];
if (formChar < '0') or (formChar > '9') then break;
formDigit := int(formChar) - int('0');
fieldWidth := fieldWidth * 10;
if fieldWidth > 1024 - formDigit then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
fieldWidth := fieldWidth + formDigit;
until false;
end;
if formChar <> '%' then begin
endIndex := formIndex + 1;
result := result + formInstance.substring(beginIndex, endIndex);
goto continue_label0;
end;
if (dataIndex < 0) or (dataIndex > dataLimit) then begin
raise ArrayIndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.array-index'));
end;
dataComponent := dataArray[dataIndex];
if dataComponent = nil then begin
raise NullPointerException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'null-pointer'));
end;
if isString then begin
formattedInstance := dataComponent.toString();
end else
if isReal then begin
if significandDigits <= 1 then significandDigits := RealRepresenter.MAX_SIGNIFICAND_DIGITS;
formattedInstance := CoReal.toString(dataComponent.asReal(), significandDigits, orderDigits, significandAll, orderDigits > 0, isExpForm, significandSign, orderSign);
end else begin
number := dataComponent.asLong();
if leadZeroOutput then begin
formattedInstance := CoLong.toLeadZeroString(number, leadZeroWidth);
end else begin
formattedInstance := CoLong.toString(number);
end;
if significandSign and (number >= 0) then formattedInstance := '+' + formattedInstance;
end;
formattedWidth := formattedInstance.length;
if fieldWidth > formattedWidth then for count := fieldWidth - formattedWidth - 1 downto 0 do result := result + ' ';
endIndex := formIndex + 1;
result := result + formattedInstance.toUTF16();
continue_label0:
beginIndex := endIndex;
endIndex := formInstance.indexOf('%', beginIndex);
end;
break_label0:
result := result + formInstance.substring(beginIndex);
end;
function UnicodeStringExtended.getLength(): int;
begin
result := system.length(self);
end;
procedure UnicodeStringExtended.getChars(beginIndex, endIndex: int; const dst: uchar_Array1d; offset: int);
var
thisLength: int;
begin
dec(endIndex);
dec(beginIndex);
thisLength := length;
if ((beginIndex or endIndex) < 0) or (beginIndex > thisLength) or (endIndex > thisLength) or (beginIndex > endIndex) then begin
raise StringIndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.string-index'));
end;
thisLength := endIndex - beginIndex;
&Array.checkBounds(dst, offset, thisLength);
&Array.copyRaw(self[beginIndex + 1], dst[offset], long(thisLength) * sizeof(uchar));
end;
function UnicodeStringExtended.equalsIgnoreCase(const anot: UnicodeString): boolean;
var
idx: int;
len: int;
begin
len := length;
if anot.length <> len then begin
result := false;
exit;
end;
for idx := len - 1 downto 0 do if CoUChar.toLowerCase(self[idx + 1]) <> CoUChar.toLowerCase(anot[idx + 1]) then begin
result := false;
exit;
end;
result := true;
end;
function UnicodeStringExtended.startsWith(const prefix: UnicodeString; position: int): boolean;
var
anotLength: int;
begin
dec(position);
anotLength := prefix.length;
if (position < 0) or (position > length - anotLength) then begin
result := false;
exit;
end;
result := (anotLength <= 0) or (&Array.compfne(self[position + 1], prefix[1], 1, anotLength) = &Array.NOT_FOUND);
end;
function UnicodeStringExtended.endsWith(const suffix: UnicodeString): boolean;
var
position: int;
anotLength: int;
begin
anotLength := suffix.length;
position := length - anotLength;
if position < 0 then begin
result := false;
exit;
end;
result := (anotLength <= 0) or (&Array.compfne(self[position + 1], suffix[1], 1, anotLength) = &Array.NOT_FOUND);
end;
function UnicodeStringExtended.indexOf(const prefix: UnicodeString; startFromIndex: int): int;
var
anotLength: int;
thisLength: int;
thisOffset: int;
firstCharValue: long;
begin
dec(startFromIndex);
anotLength := prefix.length;
thisLength := length - anotLength;
if startFromIndex < 0 then begin
startFromIndex := 0;
end;
if startFromIndex > thisLength then begin
result := 0;
exit;
end;
if anotLength <= 0 then begin
result := startFromIndex + 1;
exit;
end;
dec(anotLength);
inc(thisLength);
firstCharValue := long(prefix[1]);
repeat
thisOffset := &Array.findfeq(self[startFromIndex + 1], 1, thisLength - startFromIndex, firstCharValue);
if thisOffset = &Array.NOT_FOUND then break;
inc(startFromIndex, thisOffset);
if (anotLength <= 0) or (&Array.compfne(self[startFromIndex + 2], prefix[2], 1, anotLength) = &Array.NOT_FOUND) then begin
result := startFromIndex + 1;
exit;
end;
inc(startFromIndex);
until startFromIndex >= thisLength;
result := 0;
end;
function UnicodeStringExtended.lastIndexOf(const prefix: UnicodeString; startFromIndex: int): int;
var
anotLength: int;
thisLength: int;
thisOffset: int;
firstCharValue: long;
begin
dec(startFromIndex);
anotLength := prefix.length;
thisLength := length - anotLength;
if startFromIndex > thisLength then begin
startFromIndex := thisLength;
end;
if startFromIndex < 0 then begin
result := 0;
exit;
end;
if anotLength <= 0 then begin
result := startFromIndex + 1;
exit;
end;
dec(anotLength);
firstCharValue := long(prefix[1]);
repeat
thisOffset := &Array.findbeq(self[startFromIndex + 1], 1, startFromIndex + 1, firstCharValue);
if thisOffset = &Array.NOT_FOUND then break;
inc(startFromIndex, thisOffset);
if (anotLength <= 0) or (&Array.compfne(self[startFromIndex + 2], prefix[2], 1, anotLength) = &Array.NOT_FOUND) then begin
result := startFromIndex + 1;
exit;
end;
dec(startFromIndex);
until startFromIndex < 0;
result := 0;
end;
function UnicodeStringExtended.replaceAll(oldCharacter, newCharacter: uchar): UnicodeString;
var
chi: int;
chj: int;
thisOffset: int;
thisLength: int;
oldCharValue: long;
begin
thisLength := length;
if (thisLength <= 0) or (oldCharacter = newCharacter) then begin
result := self;
exit;
end;
oldCharValue := long(oldCharacter);
thisOffset := &Array.findfeq(self[1], 1, thisLength, oldCharValue);
if thisOffset = &Array.NOT_FOUND then begin
result := self;
exit;
end;
result := create(thisLength);
chi := 0;
chj := thisOffset;
repeat
&Array.copyRaw(self[chi + 1], result[chi + 1], long(chj - chi) * sizeof(uchar));
if chj >= thisLength then break;
result[chj + 1] := newCharacter;
chi := chj + 1;
if chi >= thisLength then break;
thisOffset := &Array.findfeq(self[chi + 1], 1, thisLength - chi, oldCharValue);
if thisOffset = &Array.NOT_FOUND then begin
chj := thisLength;
continue;
end;
chj := chi + thisOffset;
until false;
end;
function UnicodeStringExtended.copy(): UnicodeString;
var
thisLength: int;
begin
thisLength := length;
result := create(thisLength);
&Array.copyRaw(self[1], result[1], long(thisLength) * sizeof(uchar));
end;
function UnicodeStringExtended.copy(beginIndex: int): UnicodeString;
var
thisLength: int;
rsltLength: int;
begin
dec(beginIndex);
thisLength := length;
if (beginIndex < 0) or (beginIndex > thisLength) then begin
raise StringIndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.string-index'));
end;
rsltLength := thisLength - beginIndex;
result := create(rsltLength);
&Array.copyRaw(self[beginIndex + 1], result[1], long(rsltLength) * sizeof(uchar));
end;
function UnicodeStringExtended.copy(beginIndex, endIndex: int): UnicodeString;
var
thisLength: int;
rsltLength: int;
begin
dec(endIndex);
dec(beginIndex);
thisLength := length;
if ((beginIndex or endIndex) < 0) or (beginIndex > thisLength) or (endIndex > thisLength) or (beginIndex > endIndex) then begin
raise StringIndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.string-index'));
end;
rsltLength := endIndex - beginIndex;
result := create(rsltLength);
&Array.copyRaw(self[beginIndex + 1], result[1], long(rsltLength) * sizeof(uchar));
end;
function UnicodeStringExtended.trim(): UnicodeString;
var
chi: int;
chj: int;
endIndex: int;
thisLength: int;
rsltLength: int;
begin
thisLength := length;
if thisLength <= 0 then begin
result := '';
exit;
end;
chi := 0;
chj := thisLength - 1;
endIndex := chj;
while (chi <= chj) and (self[chi + 1] <= #$0020) do begin
inc(chi);
end;
while (chi <= chj) and (self[chj + 1] <= #$0020) do begin
dec(chj);
end;
if chi > chj then begin
result := '';
exit;
end;
if (chi = 0) and (chj = endIndex) then begin
result := self;
exit;
end;
rsltLength := chj - chi + 1;
result := create(rsltLength);
&Array.copyRaw(self[chi + 1], result[1], long(rsltLength) * sizeof(uchar));
end;
function UnicodeStringExtended.substring(beginIndex: int): UnicodeString;
var
thisLength: int;
rsltLength: int;
begin
dec(beginIndex);
thisLength := length;
if (beginIndex < 0) or (beginIndex > thisLength) then begin
raise StringIndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.string-index'));
end;
if beginIndex = thisLength then begin
result := '';
exit;
end;
if beginIndex = 0 then begin
result := self;
exit;
end;
rsltLength := thisLength - beginIndex;
result := create(rsltLength);
&Array.copyRaw(self[beginIndex + 1], result[1], long(rsltLength) * sizeof(uchar));
end;
function UnicodeStringExtended.substring(beginIndex, endIndex: int): UnicodeString;
var
thisLength: int;
rsltLength: int;
begin
dec(endIndex);
dec(beginIndex);
thisLength := length;
if ((beginIndex or endIndex) < 0) or (beginIndex > thisLength) or (endIndex > thisLength) or (beginIndex > endIndex) then begin
raise StringIndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.string-index'));
end;
if beginIndex = endIndex then begin
result := '';
exit;
end;
if beginIndex = endIndex - thisLength then begin
result := self;
exit;
end;
rsltLength := endIndex - beginIndex;
result := create(rsltLength);
&Array.copyRaw(self[beginIndex + 1], result[1], long(rsltLength) * sizeof(uchar));
end;
function UnicodeStringExtended.toLowerCase(): UnicodeString;
var
character: uchar;
thisLength: int;
idx: int;
label
break_label0;
begin
thisLength := length;
idx := 0;
begin
while idx < thisLength do begin
character := self[idx + 1];
if character <> CoUChar.toLowerCase(character) then goto break_label0;
inc(idx);
end;
result := self;
exit;
end;
break_label0:
result := create(thisLength);
&Array.copyRaw(self[1], result[1], long(idx) * sizeof(uchar));
while idx < thisLength do begin
result[idx + 1] := CoUChar.toLowerCase(self[idx + 1]);
inc(idx);
end;
end;
function UnicodeStringExtended.toUpperCase(): UnicodeString;
var
character: uchar;
thisLength: int;
idx: int;
label
break_label0;
begin
thisLength := length;
idx := 0;
begin
while idx < thisLength do begin
character := self[idx + 1];
if character <> CoUChar.toUpperCase(character) then goto break_label0;
inc(idx);
end;
result := self;
exit;
end;
break_label0:
result := create(thisLength);
&Array.copyRaw(self[1], result[1], long(idx) * sizeof(uchar));
while idx < thisLength do begin
result[idx + 1] := CoUChar.toUpperCase(self[idx + 1]);
inc(idx);
end;
end;
function UnicodeStringExtended.toUTF8(): AnsiString;
var
idx: int;
cap: int;
slen: int;
rlen: int;
code: int;
char1: int;
char2: int;
buf: byte_Array1d;
begin
slen := length;
if slen <= 0 then begin
result := '';
exit;
end;
rlen := 0;
cap := int(CoLong.min(long(slen) * 4, CoInt.MAX_VALUE));
buf := &Array.newByte1d(cap);
idx := 0;
while idx < slen do begin
char1 := int(self[idx + 1]);
inc(idx);
if (char1 < $d800) or (char1 >= $e000) then begin
code := char1;
end else
if char1 >= $dc00 then begin
code := char1 and $03ff;
end else begin
char2 := 0;
if idx < slen then begin
char2 := int(self[idx + 1]);
if (char2 < $dc00) or (char2 >= $e000) then begin
char2 := 0;
end else begin
inc(idx);
end;
end;
code := ((char1 and $03ff) shl 10) + (char2 and $03ff) + $010000;
end;
if (code >= $000001) and (code < $000080) then begin
if rlen >= cap then break;
buf[rlen] := byte(code);
inc(rlen);
end else
if (code >= $000000) and (code < $000800) then begin
if rlen >= cap - 1 then break;
buf[rlen] := byte($c0 + (code shr 6));
buf[rlen + 1] := byte($80 + (code and $3f));
inc(rlen, 2);
end else
if (code >= $000800) and (code < $010000) then begin
if rlen >= cap - 2 then break;
buf[rlen] := byte($e0 + (code shr 12));
buf[rlen + 1] := byte($80 + ((code shr 6) and $3f));
buf[rlen + 2] := byte($80 + (code and $3f));
inc(rlen, 3);
end else
if (code >= $010000) and (code < $200000) then begin
if rlen >= cap - 3 then break;
buf[rlen] := byte($f0 + (code shr 18));
buf[rlen + 1] := byte($80 + ((code shr 12) and $3f));
buf[rlen + 2] := byte($80 + ((code shr 6) and $3f));
buf[rlen + 3] := byte($80 + (code and $3f));
inc(rlen, 4);
end;
end;
result := AnsiString.create(buf, 0, rlen);
end;
function UnicodeStringExtended.toShortArray(): short_Array1d;
var
thisLength: int;
begin
thisLength := length;
result := &Array.newShort1d(thisLength);
&Array.copyRaw(self[1], result[0], long(thisLength) * sizeof(uchar));
end;
function UnicodeStringExtended.toUCharArray(): uchar_Array1d;
var
thisLength: int;
begin
thisLength := length;
result := &Array.newUChar1d(thisLength);
&Array.copyRaw(self[1], result[0], long(thisLength) * sizeof(uchar));
end;
function UnicodeStringExtended.toCharCodes(): int_Array1d;
var
idx: int;
slen: int;
rlen: int;
code: int;
char1: int;
char2: int;
buf: int_Array1d;
cpy: int_Array1d;
begin
slen := length;
if slen <= 0 then begin
result := &Array.newInt1d(0);
exit;
end;
rlen := 0;
buf := &Array.newInt1d(slen);
idx := 0;
while idx < slen do begin
char1 := int(self[idx + 1]);
inc(idx);
if (char1 < $d800) or (char1 >= $e000) then begin
code := char1;
end else
if char1 >= $dc00 then begin
code := char1 and $03ff;
end else begin
char2 := 0;
if idx < slen then begin
char2 := int(self[idx + 1]);
if (char2 < $dc00) or (char2 >= $e000) then begin
char2 := 0;
end else begin
inc(idx);
end;
end;
code := ((char1 and $03ff) shl 10) + (char2 and $03ff) + $010000;
end;
buf[rlen] := code;
inc(rlen);
end;
if slen = rlen then begin
result := buf;
exit;
end;
cpy := &Array.newInt1d(rlen);
&Array.copyPrimitives(buf, 0, cpy, 0, rlen);
result := cpy;
end;
function UnicodeStringExtended.split(): UnicodeString_Array1d;
var
findLimit: int;
endOffset0: int;
endOffset1: int;
beginIndex: int;
thisLength: int;
boundsLength: int;
substringLength: int;
substringInstance: UnicodeString;
substringBounds: int2;
boundsData: int2_Array1d;
boundsCopy: int2_Array1d;
begin
thisLength := length;
boundsLength := 0;
boundsData := newInt2Array1d($0f);
beginIndex := 0;
while (beginIndex <= thisLength) and (beginIndex >= 0) do begin
if beginIndex >= thisLength then begin
endOffset0 := 0;
endOffset1 := 0;
end else begin
findLimit := thisLength - beginIndex;
endOffset0 := &Array.findfeq(self[beginIndex + 1], 1, findLimit, $000a);
endOffset1 := &Array.findfeq(self[beginIndex + 1], 1, findLimit, $000d);
if endOffset0 = &Array.NOT_FOUND then endOffset0 := findLimit;
if endOffset1 = &Array.NOT_FOUND then endOffset1 := findLimit;
end;
if endOffset0 >= endOffset1 then begin
endOffset0 := endOffset1;
end;
if boundsLength = system.length(boundsData) then begin
boundsCopy := newInt2Array1d((boundsLength shl 1) or 1);
&Array.copyRaw(boundsData[0], boundsCopy[0], boundsLength * sizeof(int2));
boundsData := boundsCopy;
end;
boundsData[boundsLength] := newInt2(beginIndex, endOffset0);
inc(boundsLength);
inc(beginIndex, endOffset0 + 1);
if (beginIndex < thisLength) and (self[beginIndex] = #$000d) and (self[beginIndex + 1] = #$000a) then inc(beginIndex);
end;
result := &Array.newUnicodeString1d(boundsLength);
while boundsLength > 0 do begin
dec(boundsLength);
substringBounds := boundsData[boundsLength];
substringLength := substringBounds[1];
if substringLength <= 0 then begin
substringInstance := '';
end else
if substringLength >= thisLength then begin
substringInstance := self;
end else begin
substringInstance := create(substringLength);
&Array.copyRaw(self[substringBounds[0] + 1], substringInstance[1], long(substringLength) * sizeof(uchar));
end;
result[boundsLength] := substringInstance;
end;
end;
{%endregion}
{%region real operators (Windows only)}
{$IFDEF WINDOWS}
operator :=(value: long): real; assembler; nostackframe;
asm
dd $000008c8
mov qword [rbp-$08], rdx
fild qword [rbp-$08]
fstp tbyte [rcx-$00]
leave
end;
operator :=(value: double): real; assembler; nostackframe;
asm
dd $000008c8
movsd qword [rbp-$08], xmm1
fld qword [rbp-$08]
fstp tbyte [rcx-$00]
leave
end;
operator +(const value: real): real; assembler; nostackframe;
asm
fld tbyte [rdx+$00]
fstp tbyte [rcx+$00]
end;
operator -(const value: real): real; assembler; nostackframe;
asm
fld tbyte [rdx+$00]
fchs
fstp tbyte [rcx+$00]
end;
operator +(const value1, value2: real): real; assembler; nostackframe;
asm
fld tbyte [rdx+$00]
fld tbyte [r8+$00]
faddp st(1), st
fstp tbyte [rcx+$00]
end;
operator -(const value1, value2: real): real; assembler; nostackframe;
asm
fld tbyte [rdx+$00]
fld tbyte [r8+$00]
fsubp st(1), st
fstp tbyte [rcx+$00]
end;
operator *(const value1, value2: real): real; assembler; nostackframe;
asm
fld tbyte [rdx+$00]
fld tbyte [r8+$00]
fmulp st(1), st
fstp tbyte [rcx+$00]
end;
operator /(const value1, value2: real): real; assembler; nostackframe;
asm
fld tbyte [rdx+$00]
fld tbyte [r8+$00]
fdivp st(1), st
fstp tbyte [rcx+$00]
end;
operator =(const value1, value2: real): boolean; assembler; nostackframe;
asm
fld tbyte [rdx+$00]
fld tbyte [rcx+$00]
fcomip st, st(1)
ffree st
fincstp
jnp @00
mov al, $ff
or eax, eax
stc
@00: sete al
movzx eax, al
end;
operator >(const value1, value2: real): boolean; assembler; nostackframe;
asm
fld tbyte [rdx+$00]
fld tbyte [rcx+$00]
fcomip st, st(1)
ffree st
fincstp
jnp @00
mov al, $ff
or eax, eax
stc
@00: seta al
movzx eax, al
end;
operator <(const value1, value2: real): boolean; assembler; nostackframe;
asm
fld tbyte [rdx+$00]
fld tbyte [rcx+$00]
fcomip st, st(1)
ffree st
fincstp
jnp @00
mov al, $ff
or eax, eax
@00: setb al
movzx eax, al
end;
operator <>(const value1, value2: real): boolean; assembler; nostackframe;
asm
fld tbyte [rdx+$00]
fld tbyte [rcx+$00]
fcomip st, st(1)
ffree st
fincstp
jnp @00
mov al, $ff
or eax, eax
stc
@00: setne al
movzx eax, al
end;
operator <=(const value1, value2: real): boolean; assembler; nostackframe;
asm
fld tbyte [rdx+$00]
fld tbyte [rcx+$00]
fcomip st, st(1)
ffree st
fincstp
jnp @00
mov al, $ff
or eax, eax
@00: setbe al
movzx eax, al
end;
operator >=(const value1, value2: real): boolean; assembler; nostackframe;
asm
fld tbyte [rdx+$00]
fld tbyte [rcx+$00]
fcomip st, st(1)
ffree st
fincstp
jnp @00
mov al, $ff
or eax, eax
stc
@00: setae al
movzx eax, al
end;
{$ENDIF}
{%endregion}
{%region TypeInformation}
constructor TypeInformation.create(info: PTypeInfo);
begin
inherited create();
fldInfo := info;
fldData := getTypeData(info);
end;
function TypeInformation.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is TypeInformation) and (TypeInformation(anot).fldInfo = fldInfo);
end;
function TypeInformation.getHashCode(): long;
begin
result := long((@fldInfo)^);
end;
function TypeInformation.toString(): AnsiString;
begin
result := AnsiString('type ') + fldInfo^.name;
end;
function TypeInformation.isInstance(ref: TObject): boolean;
begin
result := false;
end;
function TypeInformation.isInstance(ref: ISimple): boolean;
begin
result := false;
end;
function TypeInformation.isInstance(ref: IUnknown): boolean;
begin
result := false;
end;
function TypeInformation.isAssignableFrom(cls: &Class): boolean;
var
anot: TObject;
begin
if (cls = nil) or (cls.queryInterface(IObjectInstance, anot) <> system.S_OK) or not(anot is TypeInformation) then begin
result := false;
exit;
end;
result := TypeInformation(anot).fldInfo = fldInfo;
end;
function TypeInformation.getTypeKind(): int;
begin
result := int(fldInfo^.kind);
end;
function TypeInformation.getUnitName(): AnsiString;
begin
result := getOriginalUnit();
end;
function TypeInformation.getSimpleName(): AnsiString;
begin
result := fldInfo^.name;
end;
function TypeInformation.getOriginalUnit(): AnsiString;
begin
result := '';
end;
function TypeInformation.getOriginalName(): AnsiString;
begin
result := fldInfo^.name;
end;
function TypeInformation.getCanonicalName(): AnsiString;
var
uname: AnsiString;
tname: AnsiString;
begin
uname := getUnitName();
tname := getSimpleName();
if uname.length <= 0 then begin
result := tname;
exit;
end;
result := uname + '.' + tname;
end;
function TypeInformation.getProperties(): Property_Array1d;
begin
result := nil;
end;
function TypeInformation.getInterfaces(): Class_Array1d;
begin
result := nil;
end;
function TypeInformation.getProperty(const name: AnsiString): &Property;
begin
result := nil;
end;
function TypeInformation.getSuperclass(): &Class;
begin
result := nil;
end;
function TypeInformation.getReference(): &Class;
begin
result := nil;
end;
function TypeInformation.getComponentType(): &Class;
begin
result := nil;
end;
{$WARN 5033 OFF} { позволить функции, состоящие только из одной управляющей конструкции raise }
function TypeInformation.createInstance(): DynamicObject;
begin
raise InstantiationException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'instantiation.object'), [ CoAnsiString.create(getCanonicalName()) ]));
end;
{$WARN 5033 ON}
{%endregion}
{%region PrimitiveTypeInformation}
constructor PrimitiveTypeInformation.create(info: PTypeInfo; kind: int; const name: AnsiString);
begin
inherited create(info);
fldKind := kind;
fldName := name;
end;
function PrimitiveTypeInformation.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is PrimitiveTypeInformation) and (PrimitiveTypeInformation(anot).fldKind = fldKind);
end;
function PrimitiveTypeInformation.getHashCode(): long;
begin
result := fldKind;
end;
function PrimitiveTypeInformation.toString(): AnsiString;
begin
result := AnsiString('type ') + fldName;
end;
function PrimitiveTypeInformation.isPointer(): boolean;
var
kind: int;
begin
kind := fldKind;
result := (kind >= Lang.TYPE_ANSISTRING) and (kind <= Lang.TYPE_WIDESTRING) or (kind >= Lang.TYPE_UNICODESTRING) and (kind <= Lang.TYPE_POINTER);
end;
function PrimitiveTypeInformation.isPrimitive(): boolean;
var
kind: int;
begin
kind := fldKind;
result := (kind < Lang.TYPE_SHORTSTRING) or (kind > Lang.TYPE_WIDESTRING) and (kind < Lang.TYPE_UNICODESTRING) or (kind > Lang.TYPE_POINTER);
end;
function PrimitiveTypeInformation.isAssignableFrom(cls: &Class): boolean;
var
anot: TObject;
begin
if (cls = nil) or (cls.queryInterface(IObjectInstance, anot) <> system.S_OK) or not(anot is PrimitiveTypeInformation) then begin
result := false;
exit;
end;
result := PrimitiveTypeInformation(anot).fldKind = fldKind;
end;
function PrimitiveTypeInformation.getTypeKind(): int;
begin
result := fldKind;
end;
function PrimitiveTypeInformation.getSimpleName(): AnsiString;
begin
result := fldName;
end;
{%endregion}
{%region PointerTypeInformation}
function PointerTypeInformation.isPointer(): boolean;
begin
result := true;
end;
function PointerTypeInformation.isPrimitive(): boolean;
begin
result := false;
end;
{%endregion}
{%region ClassTypeInformation}
class function ClassTypeInformation.typeInfoToLangType(tinfo: PTypeInfo): int;
var
tdata: PTypeData;
tkind: TTypeKind;
label
break_label0;
begin
{$IFDEF WINDOWS}
if tinfo = typeInfo(real) then begin
result := Lang.TYPE_REAL;
exit;
end;
{$ENDIF}
tdata := getTypeData(tinfo);
tkind := tinfo^.kind;
begin
case tkind of
tkUChar, tkWChar: begin
result := Lang.TYPE_UCHAR;
exit;
end;
tkEnumeration: begin
result := Lang.TYPE_INT;
exit;
end;
tkInteger: begin
case tdata^.ordType of
otSByte:
result := Lang.TYPE_BYTE;
otSWord:
result := Lang.TYPE_SHORT;
otUByte:
result := Lang.TYPE_UBYTE;
otUWord:
result := Lang.TYPE_USHORT;
otULong:
result := Lang.TYPE_UINT;
else
goto break_label0;
end;
exit;
end;
tkFloat: begin
case tdata^.floatType of
ftDouble:
result := Lang.TYPE_DOUBLE;
{$IFNDEF WINDOWS}
ftExtended:
result := Lang.TYPE_REAL;
{$ENDIF}
ftComp:
result := Lang.TYPE_COMP;
ftCurr:
result := Lang.TYPE_CURRENCY;
else
goto break_label0;
end;
exit;
end;
end;
end;
break_label0:
result := int(tkind);
end;
class function ClassTypeInformation.propInfoToProperty(pinfo: PPropInfo): &Property;
var
procs: int;
begin
if pinfo = nil then begin
result := nil;
exit;
end;
procs := pinfo^.propProcs;
result := PropertyInformation.create(
(procs and (3 shl 0)) <> (ptConst shl 0),
(procs and (3 shl 2)) <> (ptConst shl 2),
(procs and (3 shl 4)) <> (ptConst shl 4),
Lang.classFor(pinfo^.propType),
pinfo^.name
);
end;
constructor ClassTypeInformation.create(info: TClass);
begin
inherited create(info.classInfo());
fldType := info;
end;
constructor ClassTypeInformation.create(info: PTypeInfo);
begin
inherited create(info);
fldType := fldData^.classType;
end;
function ClassTypeInformation.toString(): AnsiString;
var
info: TClass;
begin
info := fldType;
result := AnsiString('class ') + info.unitName().toLowerCase() + '.' + info.className();
end;
function ClassTypeInformation.isInstance(ref: TObject): boolean;
var
info: TClass;
anot: TClass;
begin
if ref = nil then begin
result := false;
exit;
end;
info := fldType;
anot := ref.classType();
result := (anot = info) or anot.inheritsFrom(info);
end;
function ClassTypeInformation.isInstance(ref: ISimple): boolean;
var
obj: TObject;
info: TClass;
anot: TClass;
begin
if (ref = nil) or (ref.queryInterface(IObjectInstance, obj) <> system.S_OK) then begin
result := false;
exit;
end;
info := fldType;
anot := obj.classType();
result := (anot = info) or anot.inheritsFrom(info);
end;
function ClassTypeInformation.isInstance(ref: IUnknown): boolean;
var
obj: TObject;
info: TClass;
anot: TClass;
begin
if (ref = nil) or (ref.queryInterface(IObjectInstance, obj) <> system.S_OK) then begin
result := false;
exit;
end;
info := fldType;
anot := obj.classType();
result := (anot = info) or anot.inheritsFrom(info);
end;
function ClassTypeInformation.isAssignableFrom(cls: &Class): boolean;
var
obj: TObject;
info: TClass;
anot: TClass;
begin
if (cls = nil) or (cls.queryInterface(IObjectInstance, obj) <> system.S_OK) or not(obj is ClassTypeInformation) then begin
result := false;
exit;
end;
info := fldType;
anot := ClassTypeInformation(obj).fldType;
result := (anot = info) or anot.inheritsFrom(info);
end;
function ClassTypeInformation.getTypeKind(): int;
begin
result := Lang.TYPE_CLASS;
end;
function ClassTypeInformation.getOriginalUnit(): AnsiString;
begin
result := AnsiString(fldData^.unitName).toLowerCase();
end;
function ClassTypeInformation.getProperties(): Property_Array1d;
var
idx: int;
len: int;
pinfo: PPropInfo;
tinfo: PTypeInfo;
tdata: PTypeData;
begin
tinfo := PTypeInfo(fldType.classInfo());
if tinfo = nil then begin
result := nil;
exit;
end;
tdata := getTypeData(tinfo);
pinfo := PPropInfo(Pointer(@(tdata^.unitName[1])) + int(tdata^.unitName[0]));
len := system.PUInt16(pinfo)^;
pinfo := Pointer(pinfo) + 2;
result := Property_Array1d(&Array.newIUnknown1d(len));
for idx := 0 to len - 1 do begin
result[idx] := propInfoToProperty(pinfo);
pinfo := PPropInfo(Pointer(@(pinfo^.name[1])) + int(pinfo^.name[0]));
end;
end;
function ClassTypeInformation.getInterfaces(): Class_Array1d;
var
idx: int;
len: int;
guid: system.TGuid;
pgid: system.PGuid;
psid: PShortString;
table: PInterfaceTable;
begin
table := fldType.getInterfaceTable();
if table = nil then begin
result := nil;
exit;
end;
with table^ do begin
len := int(entryCount);
result := Class_Array1d(&Array.newIUnknown1d(len));
for idx := len - 1 downto 0 do begin
with entries[idx] do begin
pgid := iid;
psid := iidstr;
end;
if pgid <> nil then begin
result[idx] := Lang.classFor(pgid^);
continue;
end;
if (psid <> nil) and guidTryParse(psid^, guid) then begin
result[idx] := Lang.classFor(guid);
continue;
end;
result[idx] := InterfaceTypeInformation.create(PTypeInfo(typeInfo(IUnknown)));
end;
end;
end;
function ClassTypeInformation.getProperty(const name: AnsiString): &Property;
begin
result := propInfoToProperty(fldType.getPropertyInfo(name));
end;
function ClassTypeInformation.getSuperclass(): &Class;
var
super: TClass;
begin
super := fldType.classParent();
if super = nil then begin
result := nil;
exit;
end;
result := ClassTypeInformation.create(super);
end;
function ClassTypeInformation.createInstance(): DynamicObject;
type
DynamicClass = class of DynamicObject;
var
info: TClass;
begin
info := fldType;
if (info <> DynamicObject) and not info.inheritsFrom(DynamicObject) then begin
raise InstantiationException.create(AnsiString.format(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'instantiation.object'), [
CoAnsiString.create(getCanonicalName())
]));
end;
result := DynamicClass(info).create();
end;
{%endregion}
{%region ClassRefTypeInformation}
constructor ClassRefTypeInformation.create(info: PTypeInfo);
begin
inherited create(info);
fldType := getTypeData(fldData^.instanceTypeRef^)^.classType;
end;
function ClassRefTypeInformation.toString(): AnsiString;
var
info: TClass;
begin
info := fldType;
result := AnsiString('class of ') + info.unitName().toLowerCase() + '.' + info.className();
end;
function ClassRefTypeInformation.isAssignableFrom(cls: &Class): boolean;
var
obj: TObject;
info: TClass;
anot: TClass;
begin
if (cls = nil) or (cls.queryInterface(IObjectInstance, obj) <> system.S_OK) or not(obj is ClassRefTypeInformation) then begin
result := false;
exit;
end;
info := fldType;
anot := ClassRefTypeInformation(obj).fldType;
result := (anot = info) or anot.inheritsFrom(info);
end;
function ClassRefTypeInformation.getTypeKind(): int;
begin
result := Lang.TYPE_CLASSREF;
end;
function ClassRefTypeInformation.getReference(): &Class;
begin
result := Lang.classFor(fldType);
end;
{%endregion}
{%region InterfaceTypeInformation}
function InterfaceTypeInformation.toString(): AnsiString;
begin
result := AnsiString('interface ') + AnsiString(fldData^.intfUnit).toLowerCase() + '.' + fldInfo^.name;
end;
function InterfaceTypeInformation.isInstance(ref: TObject): boolean;
begin
result := (ref <> nil) and (ref.getInterfaceEntry(fldData^.guid) <> nil);
end;
function InterfaceTypeInformation.isInstance(ref: ISimple): boolean;
var
obj: TObject;
begin
if ref = nil then begin
result := false;
exit;
end;
if fldInfo^.kind = tkInterface then begin
result := (ref.queryInterface(IObjectInstance, obj) = system.S_OK) and (obj.getInterfaceEntry(fldData^.guid) <> nil);
exit;
end;
result := ref.queryInterface(fldData^.guid, obj) = system.S_OK;
end;
function InterfaceTypeInformation.isInstance(ref: IUnknown): boolean;
var
intfRC: IUnknown;
intfRaw: ISimple;
begin
if ref = nil then begin
result := false;
exit;
end;
if fldInfo^.kind = tkInterface then begin
result := ref.queryInterface(fldData^.guid, intfRC) = system.S_OK;
exit;
end;
result := ref.queryInterface(fldData^.guid, intfRaw) = system.S_OK;
end;
function InterfaceTypeInformation.isAssignableFrom(cls: &Class): boolean;
var
obj: TObject;
info: PTypeInfo;
anot: PTypeInfo;
iptr: PPTypeInfo;
begin
if (cls = nil) or (cls.queryInterface(IObjectInstance, obj) <> system.S_OK) or not(obj is InterfaceTypeInformation) then begin
result := false;
exit;
end;
info := fldInfo;
anot := InterfaceTypeInformation(obj).fldInfo;
repeat
if info = anot then begin
result := true;
exit;
end;
iptr := getTypeData(anot)^.intfParentRef;
if iptr = nil then break;
anot := iptr^;
until false;
result := false;
end;
function InterfaceTypeInformation.getOriginalUnit(): AnsiString;
begin
result := AnsiString(fldData^.intfUnit).toLowerCase();
end;
function InterfaceTypeInformation.getInterfaces(): Class_Array1d;
var
iptr: PPTypeInfo;
begin
iptr := fldData^.intfParentRef;
if iptr = nil then begin
result := nil;
exit;
end;
result := [ InterfaceTypeInformation.create(iptr^) as &Class ];
end;
{%endregion}
{%region DynamicArrayTypeInformation}
constructor DynamicArrayTypeInformation.create(info: PTypeInfo);
var
component: PPTypeInfo;
begin
inherited create(info);
component := fldData^.elTypeRef;
if component = nil then component := fldData^.elType2Ref;
fldComponent := component^;
end;
function DynamicArrayTypeInformation.toString(): AnsiString;
begin
result := AnsiString('array ') + Lang.classFor(fldComponent).getCanonicalName() + '[]';
end;
function DynamicArrayTypeInformation.isAssignableFrom(cls: &Class): boolean;
var
obj: TObject;
info: PTypeInfo;
anot: PTypeInfo;
begin
if (cls = nil) or (cls.queryInterface(IObjectInstance, obj) <> system.S_OK) or not(obj is DynamicArrayTypeInformation) then begin
result := false;
exit;
end;
info := fldComponent;
anot := DynamicArrayTypeInformation(obj).fldComponent;
result := (info = anot) or Lang.classFor(info).isAssignableFrom(Lang.classFor(anot));
end;
function DynamicArrayTypeInformation.getTypeKind(): int;
begin
result := Lang.TYPE_ARRAY_DYNAMIC;
end;
function DynamicArrayTypeInformation.getUnitName(): AnsiString;
begin
result := Lang.classFor(fldComponent).getUnitName();
end;
function DynamicArrayTypeInformation.getSimpleName(): AnsiString;
begin
result := Lang.classFor(fldComponent).getSimpleName() + '[]';
end;
function DynamicArrayTypeInformation.getOriginalUnit(): AnsiString;
begin
result := AnsiString(fldData^.dynUnitName).toLowerCase();
end;
function DynamicArrayTypeInformation.getComponentType(): &Class;
begin
result := Lang.classFor(fldComponent);
end;
{%endregion}
{%region FunctionTypeInformation}
function FunctionTypeInformation.isAssignableFrom(cls: &Class): boolean;
type
PProcedureSignature = ^TProcedureSignature;
var
idx: int;
len: int;
obj: TObject;
info: PProcedureSignature;
anot: PProcedureSignature;
iarg: PProcedureParam;
aarg: PProcedureParam;
begin
if (cls = nil) or (cls.queryInterface(IObjectInstance, obj) <> system.S_OK) or not(obj is FunctionTypeInformation) then begin
result := false;
exit;
end;
info := @(fldData^.procSig);
anot := @(FunctionTypeInformation(obj).fldData^.procSig);
if info <> anot then begin
len := info^.paramCount;
if (info^.cc <> anot^.cc) or (len <> anot^.paramCount) or (info^.resultType <> anot^.resultType) then begin
result := false;
exit;
end;
for idx := 0 to len - 1 do begin
iarg := info^.getParam(idx);
aarg := anot^.getParam(idx);
if ((byte((@(iarg^.paramFlags))^) and $7f) <> (byte((@(aarg^.paramFlags))^) and $7f)) or (iarg^.paramType <> aarg^.paramType) then begin
result := false;
exit;
end;
end;
end;
result := true;
end;
function FunctionTypeInformation.getTypeKind(): int;
begin
result := Lang.TYPE_FUNCTION;
end;
{%endregion}
{%region StructuredTypeInformation}
function StructuredTypeInformation.isPointer(): boolean;
begin
result := false;
end;
function StructuredTypeInformation.isPrimitive(): boolean;
begin
result := false;
end;
{%endregion}
{%region PropertyInformation}
constructor PropertyInformation.create(readable, writeable, storeable: boolean; &type: &Class; const name: AnsiString);
var
flags: int;
begin
inherited create();
flags := 0;
if readable then flags := flags or 1;
if writeable then flags := flags or 2;
if storeable then flags := flags or 4;
fldFlags := flags;
fldName := name;
fldType := &type;
end;
function PropertyInformation.isReadable(): boolean;
begin
result := (fldFlags and 1) <> 0;
end;
function PropertyInformation.isWriteable(): boolean;
begin
result := (fldFlags and 2) <> 0;
end;
function PropertyInformation.isStoreable(): boolean;
begin
result := (fldFlags and 4) <> 0;
end;
function PropertyInformation.getName(): AnsiString;
begin
result := fldName;
end;
function PropertyInformation.getType(): &Class;
begin
result := fldType;
end;
{%endregion}
{%region ThreadCollection}
constructor ThreadCollection.create(const threads: Thread_Array1d);
begin
inherited create();
fldThreads := threads;
end;
destructor ThreadCollection.destroy;
var
index: int;
threadsData: Thread_Array1d;
threadRef: Thread;
begin
threadsData := fldThreads;
for index := system.length(threadsData) - 1 downto 0 do begin
threadRef := threadsData[index];
if threadRef.isAlive() then begin
threadDecrementEnum(threadRef);
continue;
end;
threadRemove(threadRef, true);
end;
threadClean();
inherited destroy;
end;
procedure ThreadCollection.copyInto(const dstArray; dstOffset: int);
var
threadsData: Thread_Array1d;
begin
threadsData := fldThreads;
&Array.copyObjects(threadsData, 0, dstArray, dstOffset, system.length(threadsData));
end;
function ThreadCollection.getLength(): int;
begin
result := system.length(fldThreads);
end;
function ThreadCollection.componentAt(index: int): Thread;
var
threadsData: Thread_Array1d;
begin
threadsData := fldThreads;
if (index < 0) or (index >= system.length(threadsData)) then begin
raise ArrayIndexOutOfBoundsException.create(AResource.readUnitResourceAsAnsiString(pascalx.lang.UNIT_NAME, 'out-of-bounds.array-index'));
end;
result := threadsData[index];
end;
function ThreadCollection.toArray(): Thread_Array1d;
var
length: int;
threadsData: Thread_Array1d;
threadsCopy: Thread_Array1d;
begin
threadsData := fldThreads;
length := system.length(threadsData);
threadsCopy := Thread_Array1d(&Array.newTObject1d(length));
&Array.copyObjects(threadsData, 0, threadsCopy, 0, length);
result := threadsCopy;
end;
{%endregion}
{%region InterfaceEntry}
constructor InterfaceEntry.create(const guid: system.TGuid; info: PTypeInfo; next: InterfaceEntry);
begin
inherited create();
self.guid := guid;
self.info := info;
self.next := next;
end;
{%endregion}
{%region ThreadEntry}
constructor ThreadEntry.create(const threadId1, threadId2: long; threadRef: Thread; next: ThreadEntry);
begin
inherited create();
self.threadId1 := threadId1;
self.threadId2 := threadId2;
self.event := eventCreate(false, false, 'Event.' + CoLong.toHexString(threadId1) + '.' + CoInt.toHexString(interlockedIncrementInt(@threadCounter)));
self.next := next;
self.threadRef := threadRef;
self.threadOld := nil;
end;
destructor ThreadEntry.destroy;
begin
eventDestroy(event);
threadOld.freeIfNecessary();
threadRef.freeIfNecessary();
inherited destroy;
end;
{%endregion}
{%region} initialization
exceptionInitialize();
default8087CW := $037f;
defaultMXCSR := $1f80;
with fpusseDefaultContext do begin
fcw := $037f;
mxcsr := $1f80;
end;
{$IFNDEF LIBRARY}
fxcontextLoadFrom(@fpusseDefaultContext);
{$ENDIF}
primitives := [
nil,
PrimitiveTypeInformation.create(typeInfo(int), Lang.TYPE_INT, 'int') as &Class,
PrimitiveTypeInformation.create(typeInfo(char), Lang.TYPE_CHAR, 'char') as &Class,
nil,
PrimitiveTypeInformation.create(typeInfo(float), Lang.TYPE_FLOAT, 'float') as &Class,
nil,
nil,
PrimitiveTypeInformation.create(typeInfo(ShortString), Lang.TYPE_SHORTSTRING, 'ShortString') as &Class,
nil,
PrimitiveTypeInformation.create(typeInfo(AnsiString), Lang.TYPE_ANSISTRING, 'AnsiString') as &Class,
PrimitiveTypeInformation.create(typeInfo(WideString), Lang.TYPE_WIDESTRING, 'WideString') as &Class,
nil,
nil,
nil,
nil,
nil,
nil,
PrimitiveTypeInformation.create(typeInfo(uchar), Lang.TYPE_UCHAR, 'uchar') as &Class,
PrimitiveTypeInformation.create(typeInfo(boolean), Lang.TYPE_BOOLEAN, 'boolean') as &Class,
PrimitiveTypeInformation.create(typeInfo(long), Lang.TYPE_LONG, 'long') as &Class,
PrimitiveTypeInformation.create(typeInfo(system.UInt64), Lang.TYPE_ULONG, 'ulong') as &Class,
nil,
nil,
nil,
PrimitiveTypeInformation.create(typeInfo(UnicodeString), Lang.TYPE_UNICODESTRING, 'UnicodeString') as &Class,
nil,
nil,
nil,
nil,
PrimitiveTypeInformation.create(typeInfo(Pointer), Lang.TYPE_POINTER, 'Pointer') as &Class,
PrimitiveTypeInformation.create(typeInfo(byte), Lang.TYPE_BYTE, 'byte') as &Class,
PrimitiveTypeInformation.create(typeInfo(system.UInt8), Lang.TYPE_UBYTE, 'ubyte') as &Class,
PrimitiveTypeInformation.create(typeInfo(short), Lang.TYPE_SHORT, 'short') as &Class,
PrimitiveTypeInformation.create(typeInfo(system.UInt16), Lang.TYPE_USHORT, 'ushort') as &Class,
nil,
PrimitiveTypeInformation.create(typeInfo(system.UInt32), Lang.TYPE_UINT, 'uint') as &Class,
nil,
nil,
nil,
PrimitiveTypeInformation.create(typeInfo(double), Lang.TYPE_DOUBLE, 'double') as &Class,
PrimitiveTypeInformation.create(typeInfo(real), Lang.TYPE_REAL, 'real') as &Class,
PrimitiveTypeInformation.create(typeInfo(system.Comp), Lang.TYPE_COMP, 'comp') as &Class,
PrimitiveTypeInformation.create(typeInfo(system.Currency), Lang.TYPE_CURRENCY, 'currency') as &Class
];
representReal := RealRepresenter.create(RealRepresenter.REAL_SIGNIFICAND_DIGITS, RealRepresenter.REAL_ORDER_DIGITS);
representFloat := RealRepresenter.create(RealRepresenter.FLOAT_SIGNIFICAND_DIGITS, RealRepresenter.FLOAT_ORDER_DIGITS);
representDouble := RealRepresenter.create(RealRepresenter.DOUBLE_SIGNIFICAND_DIGITS, RealRepresenter.DOUBLE_ORDER_DIGITS);
interfaceInitialize();
threadInitialize();
{$IFNDEF LIBRARY}
threadAdd(Thread.create(threadGetCurrentId(), {$IFDEF WINDOWS}-2{$ELSE}threadGetCurrentId2(){$ENDIF}, false));
{$ENDIF}
resourcestringOverrides := AResource.readResourceAsAnsiString('resourcestring').split();
if system.length(resourcestringOverrides) > 0 then try
objpas.setResourceStrings(TResourceIterator(@resourcestringOverride), nil);
finally
resourcestringOverrides := nil;
end;
Lang.registerInterfaces([
typeInfo(IUnknown),
typeInfo(IDispatch),
typeInfo(IInvokable),
typeInfo(ISimple),
typeInfo(RawInterface),
typeInfo(RefCountInterface),
typeInfo(&Property),
typeInfo(&Class),
typeInfo(Runnable),
typeInfo(Value),
typeInfo(Serializable)
]);
{%endregion}
{%region} finalization
threadFinalize();
interfaceFinalize();
representDouble.free();
representFloat.free();
representReal.free();
primitives := nil;
exceptionFinalize();
{%endregion}
end.
