{
pascalx.lang — основной модуль для разработки программ и библиотек.
Copyright © 2021 Малик Разработчик
Это свободная программа: вы можете перераспространять её и/или
изменять её на условиях Меньшей Стандартной общественной лицензии GNU в том виде,
в каком она была опубликована Фондом свободного программного обеспечения;
либо версии 3 лицензии, либо (по вашему выбору) любой более поздней версии.
Эта программа распространяется в надежде, что она может быть полезна,
но БЕЗО ВСЯКИХ ГАРАНТИЙ; даже без неявной гарантии ТОВАРНОГО ВИДА
или ПРИГОДНОСТИ ДЛЯ ОПРЕДЕЛЁННЫХ ЦЕЛЕЙ. Подробнее см. в Меньшей Стандартной
общественной лицензии GNU.
Вы должны были получить копию Меньшей Стандартной общественной лицензии GNU
вместе с этой программой. Если это не так, см.
<http://www.gnu.org/licenses/>.
}
unit pascalx.lang;
{$MODE OBJFPC}
interface
uses
{$IFDEF WINDOWS} windows, {$ENDIF}
interfacebase,
sysutils,
classes,
typinfo;
{$ASMMODE INTEL,CALLING REGISTER,INLINE ON,TYPEINFO ON}
{%region public }
type
_Interface = interface;
_Property = interface;
_Class = interface;
Runnable = interface;
Value = interface;
ValueExtended = interface;
_Object = class;
RefCountInterfacedObject = class;
DynamicalyAllocatedObject = class;
ValueOfBoolean = class;
ValueOfLong = class;
ValueOfFloat = class;
ValueOfDouble = class;
ValueOfReal = class;
ValueOfAnsiString = class;
ValueOfUnicodeString = class;
ValueOfObject = class;
ValueOfInterface = class;
RealValueRepresenter = class;
Task = class;
Thread = class;
Monitor = class;
Throwable = class;
Exception = class;
PropertyException = class;
PropertyNotFoundException = class;
IllegalPropertyTypeException = class;
IllegalPropertyAccessException = class;
RuntimeException = class;
ArithmeticException = class;
ClassCastException = class;
IllegalStateException = class;
IllegalMonitorStateException = class;
IllegalArgumentException = class;
NumberFormatException = class;
IndexOutOfBoundsException = class;
ArrayIndexOutOfBoundsException = class;
StringIndexOutOfBoundsException = class;
NegativeArraySizeException = class;
NullPointerException = class;
SecurityException = class;
UnsupportedOperationException = class;
Error = class;
ClassContentError = class;
AbstractMethodError = class;
MachineError = class;
StackOverflowError = class;
MemoryError = class;
OutOfMemoryError = class;
InvalidPointerError = class;
boolean = system.Boolean;
char = system.Char;
wchar = system.WideChar;
byte = system.Int8;
short = system.Int16;
int = system.Int32;
long = system.Int64;
float = system.Single;
double = system.Double;
real = packed array [0..9] of system.UInt8;
{ boolean[] } boolean_Array1d = packed array of boolean;
{ char[] } char_Array1d = packed array of char;
{ wchar[] } wchar_Array1d = packed array of wchar;
{ byte[] } byte_Array1d = packed array of byte;
{ short[] } short_Array1d = packed array of short;
{ int[] } int_Array1d = packed array of int;
{ long[] } long_Array1d = packed array of long;
{ float[] } float_Array1d = packed array of float;
{ double[] } double_Array1d = packed array of double;
{ real[] } real_Array1d = packed array of real;
{ TObject[] } TObject_Array1d = packed array of TObject;
{ IUnknown[] } IUnknown_Array1d = packed array of IUnknown;
{ _Property[] } _Property_Array1d = packed array of _Property;
{ _Class[] } _Class_Array1d = packed array of _Class;
{ Runnable[] } Runnable_Array1d = packed array of Runnable;
{ Value[] } Value_Array1d = packed array of Value;
{ AnsiString[] } AnsiString_Array1d = packed array of AnsiString;
{ UnicodeString[] } UnicodeString_Array1d = packed array of UnicodeString;
{ boolean[][] } boolean_Array2d = packed array of boolean_Array1d;
{ char[][] } char_Array2d = packed array of char_Array1d;
{ wchar[][] } wchar_Array2d = packed array of wchar_Array1d;
{ byte[][] } byte_Array2d = packed array of byte_Array1d;
{ short[][] } short_Array2d = packed array of short_Array1d;
{ int[][] } int_Array2d = packed array of int_Array1d;
{ long[][] } long_Array2d = packed array of long_Array1d;
{ float[][] } float_Array2d = packed array of float_Array1d;
{ double[][] } double_Array2d = packed array of double_Array1d;
{ real[][] } real_Array2d = packed array of real_Array1d;
{ TObject[][] } TObject_Array2d = packed array of TObject_Array1d;
{ IUnknown[][] } IUnknown_Array2d = packed array of IUnknown_Array1d;
{ _Property[][] } _Property_Array2d = packed array of _Property_Array1d;
{ _Class[][] } _Class_Array2d = packed array of _Class_Array1d;
{ Runnable[][] } Runnable_Array2d = packed array of Runnable_Array1d;
{ Value[][] } Value_Array2d = packed array of Value_Array1d;
{ AnsiString[][] } AnsiString_Array2d = packed array of AnsiString_Array1d;
{ UnicodeString[][] } UnicodeString_Array2d = packed array of UnicodeString_Array1d;
TObjectExtended = class helper for TObject
private
class function getPropertyInfo(const name: AnsiString): PPropInfo;
public
function getClass(): _Class;
function getIdentityHashCode(): long;
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 readPropertyOfObject(const name: AnsiString): TObject;
function readPropertyOfInterface(const name: AnsiString): IUnknown;
function readPropertyOfAnsiString(const name: AnsiString): AnsiString;
function readPropertyOfUnicodeString(const name: AnsiString): UnicodeString;
procedure writePropertyOfBoolean(const name: AnsiString; value: boolean);
procedure writePropertyOfLong(const name: AnsiString; value: long);
procedure writePropertyOfDouble(const name: AnsiString; value: double);
procedure writePropertyOfObject(const name: AnsiString; value: TObject);
procedure writePropertyOfInterface(const name: AnsiString; value: IUnknown);
procedure writePropertyOfAnsiString(const name: AnsiString; const value: AnsiString);
procedure writePropertyOfUnicodeString(const name: AnsiString; const value: UnicodeString);
end;
_Interface = interface(IUnknown) ['{F5377D1E-7AF2-4BBA-822E-778B4F7D652F}']
function getInterface(const iid: TGuid; out obj): boolean; overload;
function getInterface(const iid: ShortString; out obj): boolean; overload;
function getInterfaceWeak(const iid: TGuid; out obj): boolean;
function getInterfaceByStr(const iid: ShortString; out obj): boolean;
function fieldAddress(const name: ShortString): Pointer;
function safeCallException(exceptObject: TObject; exceptAddress: Pointer): HResult;
function equals(anot: TObject): boolean;
function getHashCode(): long;
function toString(): AnsiString;
procedure dispatch(var message);
procedure dispatchStr(var message);
procedure defaultHandler(var message);
procedure defaultHandlerStr(var message);
end;
_Property = interface(_Interface) ['{F5377D1E-7AF2-4BBA-822E-778B4F7D6530}']
function isReadable(): boolean;
function isWriteable(): boolean;
function isStoreable(): boolean;
function getType(): _Class;
function getName(): AnsiString;
end;
_Class = interface(_Interface) ['{F5377D1E-7AF2-4BBA-822E-778B4F7D6531}']
function isPrimitive(): boolean;
function isInterface(): boolean;
function isInstance(ref: TObject): boolean;
function isAssignableFrom(cls: _Class): boolean;
function getPrimitiveType(): int;
function getProperty(const name: AnsiString): _Property;
function getSuperclass(): _Class;
function getInterfaces(): _Class_Array1d;
function getProperties(): _Property_Array1d;
function getCanonicalName(): AnsiString;
function getSimpleName(): AnsiString;
function getUnitName(): AnsiString;
function createInstance(): DynamicalyAllocatedObject;
end;
Runnable = interface(_Interface) ['{5BF760E3-0DD8-49EE-AEB9-F3A7978E21CD}']
procedure run();
end;
Value = interface(_Interface) ['{A3919068-04E5-47B0-A10D-591E2A664127}']
function getType(): int;
function booleanValue(): boolean;
function intValue(): int;
function longValue(): long;
function floatValue(): float;
function doubleValue(): double;
function realValue(): real;
function ansiStringValue(): AnsiString;
function unicodeStringValue(): UnicodeString;
function objectValue(): TObject;
function interfaceValue(): IUnknown;
end;
ValueExtended = interface(Value) ['{A3919068-04E5-47B0-A10D-591E2A664128}']
function getSize(): int;
procedure writeToByteArray(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLE(const dst: byte_Array1d; offset: int);
end;
_Object = class(TObject, IUnknown, _Interface)
public
constructor create();
destructor destroy; override;
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function queryInterface({$IFDEF FPC_HAS_CONSTREF} constref {$ELSE} const {$ENDIF} iid: TGuid; out obj): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF}; virtual;
function _addref(): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF}; virtual;
function _release(): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF}; virtual;
procedure afterConstruction(); override;
procedure beforeDestruction(); override;
end;
RefCountInterfacedObject = class(_Object)
public
class function newInstance(): TObject; override; final;
public
function _addref(): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF}; override; final;
function _release(): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF}; override; final;
procedure afterConstruction(); override; final;
procedure beforeDestruction(); override; final;
private
refcount: int;
end;
DynamicalyAllocatedObject = class(RefCountInterfacedObject)
public
constructor create(); virtual;
end;
ValueOfBoolean = class(RefCountInterfacedObject, Value, ValueExtended)
public
constructor create(value: boolean);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getType(): int;
function booleanValue(): boolean;
function intValue(): int;
function longValue(): long;
function floatValue(): float;
function doubleValue(): double;
function realValue(): real;
function ansiStringValue(): AnsiString;
function unicodeStringValue(): UnicodeString;
function objectValue(): TObject;
function interfaceValue(): IUnknown;
function getSize(): int;
procedure writeToByteArray(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLE(const dst: byte_Array1d; offset: int);
private
value: byte;
end;
ValueOfLong = class(RefCountInterfacedObject, Value, ValueExtended)
public
constructor create(value: long; &type: int = 0);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getType(): int;
function booleanValue(): boolean;
function intValue(): int;
function longValue(): long;
function floatValue(): float;
function doubleValue(): double;
function realValue(): real;
function ansiStringValue(): AnsiString;
function unicodeStringValue(): UnicodeString;
function objectValue(): TObject;
function interfaceValue(): IUnknown;
function getSize(): int;
procedure writeToByteArray(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLE(const dst: byte_Array1d; offset: int);
private
value: long;
&type: int;
end;
ValueOfFloat = class(RefCountInterfacedObject, Value, ValueExtended)
public
constructor create(value: float);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getType(): int;
function booleanValue(): boolean;
function intValue(): int;
function longValue(): long;
function floatValue(): float;
function doubleValue(): double;
function realValue(): real;
function ansiStringValue(): AnsiString;
function unicodeStringValue(): UnicodeString;
function objectValue(): TObject;
function interfaceValue(): IUnknown;
function getSize(): int;
procedure writeToByteArray(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLE(const dst: byte_Array1d; offset: int);
private
value: float;
end;
ValueOfDouble = class(RefCountInterfacedObject, Value, ValueExtended)
public
constructor create(value: double);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getType(): int;
function booleanValue(): boolean;
function intValue(): int;
function longValue(): long;
function floatValue(): float;
function doubleValue(): double;
function realValue(): real;
function ansiStringValue(): AnsiString;
function unicodeStringValue(): UnicodeString;
function objectValue(): TObject;
function interfaceValue(): IUnknown;
function getSize(): int;
procedure writeToByteArray(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLE(const dst: byte_Array1d; offset: int);
private
value: double;
end;
ValueOfReal = class(RefCountInterfacedObject, Value, ValueExtended)
private
class function realIsEquals(const value1, value2: real): boolean; static;
public
constructor create(const value: real);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getType(): int;
function booleanValue(): boolean;
function intValue(): int;
function longValue(): long;
function floatValue(): float;
function doubleValue(): double;
function realValue(): real;
function ansiStringValue(): AnsiString;
function unicodeStringValue(): UnicodeString;
function objectValue(): TObject;
function interfaceValue(): IUnknown;
function getSize(): int;
procedure writeToByteArray(const dst: byte_Array1d; offset: int);
procedure writeToByteArrayLE(const dst: byte_Array1d; offset: int);
private
value: real;
end;
ValueOfAnsiString = class(RefCountInterfacedObject, Value)
public
constructor create(const value: AnsiString);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getType(): int;
function booleanValue(): boolean;
function intValue(): int;
function longValue(): long;
function floatValue(): float;
function doubleValue(): double;
function realValue(): real;
function ansiStringValue(): AnsiString;
function unicodeStringValue(): UnicodeString;
function objectValue(): TObject;
function interfaceValue(): IUnknown;
private
value: AnsiString;
end;
ValueOfUnicodeString = class(RefCountInterfacedObject, Value)
public
constructor create(const value: UnicodeString);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getType(): int;
function booleanValue(): boolean;
function intValue(): int;
function longValue(): long;
function floatValue(): float;
function doubleValue(): double;
function realValue(): real;
function ansiStringValue(): AnsiString;
function unicodeStringValue(): UnicodeString;
function objectValue(): TObject;
function interfaceValue(): IUnknown;
private
value: UnicodeString;
end;
ValueOfObject = class(RefCountInterfacedObject, Value)
public
constructor create(value: TObject; owned: boolean = true);
destructor destroy; override;
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getType(): int;
function booleanValue(): boolean; virtual;
function intValue(): int; virtual;
function longValue(): long; virtual;
function floatValue(): float; virtual;
function doubleValue(): double; virtual;
function realValue(): real; virtual;
function ansiStringValue(): AnsiString; virtual;
function unicodeStringValue(): UnicodeString; virtual;
function objectValue(): TObject;
function interfaceValue(): IUnknown;
private
value: TObject;
owned: boolean;
end;
ValueOfInterface = class(RefCountInterfacedObject, Value)
public
constructor create(value: IUnknown);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function getType(): int;
function booleanValue(): boolean; virtual;
function intValue(): int; virtual;
function longValue(): long; virtual;
function floatValue(): float; virtual;
function doubleValue(): double; virtual;
function realValue(): real; virtual;
function ansiStringValue(): AnsiString; virtual;
function unicodeStringValue(): UnicodeString; virtual;
function objectValue(): TObject;
function interfaceValue(): IUnknown;
private
value: IUnknown;
end;
RealValueRepresenter = class(_Object)
public
class function pow10(const value: real; power: int): real; static;
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;
public
constructor create(significandDigits, orderDigits: int; orderRequired: boolean = false);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function parseReal(const str: AnsiString): real; virtual;
function parseFloat(const str: AnsiString): float; virtual;
function parseDouble(const str: AnsiString): double; virtual;
function getOrderDigits(): int; virtual;
function getSignificandDigits(): int; virtual;
function toString(const value: real): AnsiString; overload; virtual;
protected
function parse(const str: AnsiString): real; virtual;
private
orderRequired: boolean;
orderDigits: int;
significandDigits: int;
minRepresentValue: long;
maxRepresentValue: long;
limitValueWithoutExponent: real;
limitValueWithFractialPart: real;
end;
Task = class(_Object, Runnable)
public
constructor create();
destructor destroy; override;
function getScheduledTime(): long;
procedure run(); virtual; abstract;
procedure cancel(); virtual;
procedure schedule(delay: int); virtual; overload;
procedure schedule(delay, period: int); virtual; overload;
protected
procedure cancelled(); virtual;
private
periodic: boolean;
period: int;
runningTime: long;
scheduledTime: long;
end;
Thread = class(TThread, IUnknown, _Interface, Runnable)
private
class var threadNumber: int;
class function nextThreadNumber(): int; static;
public
constructor create(); overload;
constructor create(const name: AnsiString); overload;
constructor create(target: Runnable); overload;
constructor create(target: Runnable; const name: AnsiString); overload;
function toString(): AnsiString; override;
function queryInterface({$IFDEF FPC_HAS_CONSTREF} constref {$ELSE} const {$ENDIF} iid: TGuid; out obj): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF}; virtual;
function _addref(): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF}; virtual;
function _release(): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF}; virtual;
function getName(): AnsiString;
procedure run(); virtual;
protected
procedure execute(); override; final;
private
fTarget: Runnable;
fName: AnsiString;
end;
Monitor = class(_Object)
private type
ThreadEntry = class;
SuspendTask = class;
ThreadEntry_Array1d = packed array of ThreadEntry;
ThreadEntry = class(_Object)
public
constructor create(owner: Monitor; monitorThread: TThread; state: int);
destructor destroy; override;
procedure suspend();
procedure resume();
private
fState: int;
fEntryCount: long;
fMonitorEvent: PRTLEvent;
fMonitorThread: TThread;
fSuspendTask: Task;
fOwner: Monitor;
end;
SuspendTask = class(Task)
public
constructor create(owner: Monitor; entry: ThreadEntry);
procedure run(); override;
private
fEntry: ThreadEntry;
fOwner: Monitor;
end;
public
procedure afterConstruction(); override; final;
procedure beforeDestruction(); override; final;
procedure notify();
procedure notifyAll();
procedure wait(millis: int = 0);
private
procedure push(entry: ThreadEntry);
procedure pop();
private
fWaitingCount: int;
fNotifiesCount: long;
fOwningEntry: ThreadEntry;
fWaitingEntries: ThreadEntry_Array1d;
fMonitorSynchronize: TRTLCriticalSection;
end;
Throwable = class(_Object)
public
constructor create(const message: AnsiString = ''; helpContext: int = 0);
function toString(): AnsiString; override;
procedure printStackTrace();
private
fMessage: AnsiString;
fHelpContext: int;
published
property helpContext: int read fHelpContext write fHelpContext;
property message: AnsiString read fMessage write fMessage;
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);
IllegalStateException = class(RuntimeException);
IllegalMonitorStateException = class(IllegalStateException);
IllegalArgumentException = class(RuntimeException);
NumberFormatException = class(IllegalArgumentException);
IndexOutOfBoundsException = class(RuntimeException);
ArrayIndexOutOfBoundsException = class(IndexOutOfBoundsException);
StringIndexOutOfBoundsException = class(IndexOutOfBoundsException);
NegativeArraySizeException = class(RuntimeException);
NullPointerException = class(RuntimeException);
SecurityException = class(RuntimeException);
UnsupportedOperationException = class(RuntimeException);
Error = class(Throwable);
ClassContentError = class(Error);
AbstractMethodError = class(ClassContentError);
MachineError = class(Error);
StackOverflowError = class(MachineError);
MemoryError = class(MachineError)
private
disallowFree: boolean;
public
procedure freeInstance(); override;
end;
OutOfMemoryError = class(MemoryError);
InvalidPointerError = class(MemoryError);
const { специальные значения }
CHAR_MIN_VALUE = char(#$00);
CHAR_MAX_VALUE = char(#$ff);
WCHAR_MIN_VALUE = wchar(#$0000);
WCHAR_MAX_VALUE = wchar(#$ffff);
BYTE_MIN_VALUE = byte(-$80);
BYTE_MAX_VALUE = byte($7f);
SHORT_MIN_VALUE = short(-$8000);
SHORT_MAX_VALUE = short($7fff);
INT_MIN_VALUE = int(-$80000000);
INT_MAX_VALUE = int($7fffffff);
LONG_MIN_VALUE = long(-$8000000000000000);
LONG_MAX_VALUE = long($7fffffffffffffff);
FLOAT_NAN = float(0.0 / 0.0);
FLOAT_POSITIVE_INFINITY = float(+1.0 / 0.0);
FLOAT_NEGATIVE_INFINITY = float(-1.0 / 0.0);
FLOAT_MIN_VALUE = float(1.40129846432481707e-45);
FLOAT_MAX_VALUE = float(3.40282346638528860e+38);
DOUBLE_NAN = double(0.0 / 0.0);
DOUBLE_POSITIVE_INFINITY = double(+1.0 / 0.0);
DOUBLE_NEGATIVE_INFINITY = double(-1.0 / 0.0);
DOUBLE_MIN_VALUE = double(4.94065645841246544e-324);
DOUBLE_MAX_VALUE = double(1.79769313486231571e+308);
DIRECTORY_SEPARATOR = char({$IF DEFINED(WINDOWS)} '\' {$ELSE} '/' {$ENDIF});
LINE_ENDING = AnsiString({$IF DEFINED(WINDOWS)} #$0d#$0a {$ELSEIF DEFINED(UNIX)} #$0a {$ELSE} #$0d {$ENDIF});
const { диапазон поддерживаемых оснований систем счисления }
MIN_RADIX = int(2);
MAX_RADIX = int(36);
const { значения для _Class }
TYPE_BOOLEAN = int(18);
TYPE_CHAR = int(2);
TYPE_WCHAR = 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(38);
TYPE_REAL = int(39); { не используется в _Class }
TYPE_ANSISTRING = int(9);
TYPE_UNICODESTRING = int(24);
TYPE_CLASS = int(15);
TYPE_INTERFACE = int(14);
const { значения для RealValueRepresenter }
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);
resourcestring
msgPropertyNotFound = 'Не найдено свойство ';
msgIllegalPropertyType = 'Другой тип свойства ';
msgIllegalPropertyAccess = 'Нет соответствующего доступа у свойства ';
msgArithmeticError = 'Ошибка арифметики';
msgClassCast = 'Ошибка приведения к типу';
msgIllegalMonitorState = 'Недопустимое состояние блокирующего монитора';
msgIllegalArgument = 'Недопустимое значение параметра ';
msgIllegalNumberFormat = 'Недопустимый формат числа';
msgIllegalRadix = 'Недопустимое основание системы счисления';
msgIndexOutOfBounds = 'Индекс выходит из диапазона';
msgArrayIndexOutOfBounds = 'Индекс элемента массива выходит из диапазона';
msgStringIndexOutOfBounds = 'Индекс символа строки выходит из диапазона';
msgNegativeArraySize = 'Длина массива не может быть отрицательной';
msgNullPointer = 'Нулевой указатель не может быть разыменован';
msgNullPointerArgument = 'Нулевой указатель в параметре ';
msgSecurity = 'Нет доступа';
msgUnsupportedOperation = 'Операция не поддерживается';
msgAbstractMethod = 'Попытка вызова абстрактного метода';
msgStackOverflow = 'Стак вызовов переполнен';
msgOutOfMemory = 'Out of memory';
msgInvalidPointer = 'Invalid pointer';
{%endregion}
{%region routine }
function charIsDigit(c: char): boolean; overload;
function charIsDigit(c: wchar): boolean; overload;
function charIsLowerCase(c: char): boolean; overload;
function charIsLowerCase(c: wchar): boolean; overload;
function charIsUpperCase(c: char): boolean; overload;
function charIsUpperCase(c: wchar): boolean; overload;
function charToLowerCase(c: char): char; overload;
function charToLowerCase(c: wchar): wchar; overload;
function charToUpperCase(c: char): char; overload;
function charToUpperCase(c: wchar): wchar; overload;
function byteParse(const str: AnsiString; radix: int = 10): byte;
function shortByteSwap(value: short): short;
function shortParse(const str: AnsiString; radix: int = 10): short;
function intBitsToFloat(bits: int): float;
function intByteSwap(value: int): int;
function intSar(value: int; bits: int): int;
function intAbs(value: int): int; inline;
function intMax(value1, value2: int): int; inline;
function intMin(value1, value2: int): int; inline;
function intBound(minimum, value, maximum: int): int; inline;
function intParse(const str: AnsiString; radix: int = 10): int;
function intToString(value: int; radix: int = 10): AnsiString;
function intToBinaryString(value: int): AnsiString;
function intToOctalString(value: int): AnsiString;
function intToHexString(value: int): AnsiString;
function intToFloat(value: int): float;
function intToDouble(value: int): double;
function longBitsToDouble(bits: long): double;
function longByteSwap(value: long): long;
function longSar(value: long; bits: int): long;
function longAbs(value: long): long; inline;
function longMax(value1, value2: long): long; inline;
function longMin(value1, value2: long): long; inline;
function longBound(minimum, value, maximum: long): long; inline;
function longParse(const str: AnsiString; radix: int = 10): long;
function longToString(value: long; radix: int = 10): AnsiString;
function longToBinaryString(value: long): AnsiString;
function longToOctalString(value: long): AnsiString;
function longToHexString(value: long): AnsiString;
function longToFloat(value: long): float;
function longToDouble(value: long): double;
function ulongCmp(uvalue1, uvalue2: long): int;
function ulongDiv(uvalue1, uvalue2: long): long;
function ulongRem(uvalue1, uvalue2: long): long;
function ulongToReal(uvalue: long): real;
function floatIsNaN(value: float): boolean;
function floatIsInfinite(value: float): boolean;
function floatToIntBits(value: float): int;
function floatCmpl(value1, value2: float): int;
function floatCmpg(value1, value2: float): int;
function floatAbs(value: float): float;
function floatMax(value1, value2: float): float;
function floatMin(value1, value2: float): float;
function floatMod(value1, value2: float): float;
function floatBound(minimum, value, maximum: float): float;
function floatParse(const str: AnsiString): float;
function floatToString(value: float): AnsiString;
function floatToInt(value: float): int;
function floatToLong(value: float): long;
function floatToDouble(value: float): double;
function doubleIsNaN(value: double): boolean;
function doubleIsInfinite(value: double): boolean;
function doubleToLongBits(value: double): long;
function doubleCmpl(value1, value2: double): int;
function doubleCmpg(value1, value2: double): int;
function doubleAbs(value: double): double;
function doubleMax(value1, value2: double): double;
function doubleMin(value1, value2: double): double;
function doubleMod(value1, value2: double): double;
function doubleBound(minimum, value, maximum: double): double;
function doubleParse(const str: AnsiString): double;
function doubleToString(value: double): AnsiString;
function doubleToInt(value: double): int;
function doubleToLong(value: double): long;
function doubleToFloat(value: double): float;
function REAL_NAN: real; inline;
function REAL_POSITIVE_INFINITY: real; inline;
function REAL_NEGATIVE_INFINITY: real; inline;
function REAL_MIN_VALUE: real; inline;
function REAL_MAX_VALUE: real; inline;
function realIsNaN(const value: real): boolean;
function realIsInfinite(const value: real): boolean;
function realBuild(exponent: int; significand: long): real; inline;
function realSignificand(const value: real): long; inline;
function realExponent(const value: real): int; inline;
function realCmpl(const value1, value2: real): int;
function realCmpg(const value1, value2: real): int;
function realAbs(const value: real): real;
function realMax(const value1, value2: real): real;
function realMin(const value1, value2: real): real;
function realMod(const value1, value2: real): real;
function realBound(const minimum, value, maximum: real): real;
function realParse(const str: AnsiString): real;
function realToString(const value: real): AnsiString;
function realToInt(const value: real): int;
function realToLong(const value: real): long;
function realToFloat(const value: real): float;
function realToDouble(const value: real): double;
function stringToUTF8(const str: UnicodeString): AnsiString;
function stringToUTF16(const str: AnsiString): UnicodeString;
function stringBuildUTF8(const charCodes: int_Array1d; offset, length: int): AnsiString;
function stringBuildUTF16(const charCodes: int_Array1d; offset, length: int): UnicodeString;
function stringToCharCodes(const str: AnsiString): int_Array1d; overload;
function stringToCharCodes(const str: UnicodeString): int_Array1d; overload;
function stringToCharArray(const str: AnsiString): char_Array1d;
function stringToWCharArray(const str: UnicodeString): wchar_Array1d;
function stringToByteArray(const str: AnsiString): byte_Array1d;
function stringToShortArray(const str: UnicodeString): short_Array1d;
function stringToLowerCase(const str: AnsiString): AnsiString; overload;
function stringToLowerCase(const str: UnicodeString): UnicodeString; overload;
function stringToUpperCase(const str: AnsiString): AnsiString; overload;
function stringToUpperCase(const str: UnicodeString): UnicodeString; overload;
function stringReplace(const str: AnsiString; oldCharacter, newCharacter: char): AnsiString; overload;
function stringReplace(const str: UnicodeString; oldCharacter, newCharacter: wchar): UnicodeString; overload;
function stringStartsWith(const prefix, str: AnsiString; position: int = 1): boolean; overload;
function stringStartsWith(const prefix, str: UnicodeString; position: int = 1): boolean; overload;
function stringEndsWith(const suffix, str: AnsiString): boolean; overload;
function stringEndsWith(const suffix, str: UnicodeString): boolean; overload;
function stringIndexOf(const prefix, str: AnsiString; startFromIndex: int = 1): int; overload;
function stringIndexOf(const prefix, str: UnicodeString; startFromIndex: int = 1): int; overload;
function stringLastIndexOf(const prefix, str: AnsiString; startFromIndex: int = INT_MAX_VALUE): int; overload;
function stringLastIndexOf(const prefix, str: UnicodeString; startFromIndex: int = INT_MAX_VALUE): int; overload;
function stringTrim(const str: AnsiString): AnsiString; overload;
function stringTrim(const str: UnicodeString): UnicodeString; overload;
function stringCopy(const str: AnsiString): AnsiString; overload;
function stringCopy(const str: AnsiString; beginIndex: int): AnsiString; overload;
function stringCopy(const str: AnsiString; beginIndex, endIndex: int): AnsiString; overload;
function stringCopy(const str: UnicodeString): UnicodeString; overload;
function stringCopy(const str: UnicodeString; beginIndex: int): UnicodeString; overload;
function stringCopy(const str: UnicodeString; beginIndex, endIndex: int): UnicodeString; overload;
function stringSplit(const str: AnsiString): AnsiString_Array1d; overload;
function stringSplit(const str: UnicodeString): UnicodeString_Array1d; overload;
function systemGetTickCount(): long;
function systemGetCurrentDirectory(): UnicodeString;
function systemGetCommandLine(): UnicodeString_Array1d;
function pointerToLongBits(p: Pointer): long; inline;
function classForType(const info: TGuid): _Class; overload;
function classForType(const info: TClass): _Class; overload;
function classForType(const info: Pointer): _Class; overload;
function classForName(const name: AnsiString): _Class;
function AnsiString_create(length: int): AnsiString; overload;
function AnsiString_create(const src: byte_Array1d; offset, length: int): AnsiString; overload;
function AnsiString_create(const src: char_Array1d; offset, length: int): AnsiString; overload;
function UnicodeString_create(length: int): UnicodeString; overload;
function UnicodeString_create(const src: short_Array1d; offset, length: int): UnicodeString; overload;
function UnicodeString_create(const src: wchar_Array1d; offset, length: int): UnicodeString; overload;
function boolean_Array1d_create(length: int): boolean_Array1d; overload;
function boolean_Array1d_create(const elements: array of boolean): boolean_Array1d; overload;
function char_Array1d_create(length: int): char_Array1d; overload;
function char_Array1d_create(const elements: array of char): char_Array1d; overload;
function wchar_Array1d_create(length: int): wchar_Array1d; overload;
function wchar_Array1d_create(const elements: array of wchar): wchar_Array1d; overload;
function byte_Array1d_create(length: int): byte_Array1d; overload;
function byte_Array1d_create(const elements: array of byte): byte_Array1d; overload;
function short_Array1d_create(length: int): short_Array1d; overload;
function short_Array1d_create(const elements: array of short): short_Array1d; overload;
function int_Array1d_create(length: int): int_Array1d; overload;
function int_Array1d_create(const elements: array of int): int_Array1d; overload;
function long_Array1d_create(length: int): long_Array1d; overload;
function long_Array1d_create(const elements: array of long): long_Array1d; overload;
function float_Array1d_create(length: int): float_Array1d; overload;
function float_Array1d_create(const elements: array of float): float_Array1d; overload;
function double_Array1d_create(length: int): double_Array1d; overload;
function double_Array1d_create(const elements: array of double): double_Array1d; overload;
function real_Array1d_create(length: int): real_Array1d; overload;
function real_Array1d_create(const elements: array of real): real_Array1d; overload;
function TObject_Array1d_create(length: int): TObject_Array1d; overload;
function TObject_Array1d_create(const elements: array of TObject): TObject_Array1d; overload;
function IUnknown_Array1d_create(length: int): IUnknown_Array1d; overload;
function IUnknown_Array1d_create(const elements: array of IUnknown): IUnknown_Array1d; overload;
function AnsiString_Array1d_create(length: int): AnsiString_Array1d; overload;
function AnsiString_Array1d_create(const elements: array of AnsiString): AnsiString_Array1d; overload;
function UnicodeString_Array1d_create(length: int): UnicodeString_Array1d; overload;
function UnicodeString_Array1d_create(const elements: array of UnicodeString): UnicodeString_Array1d; overload;
function boolean_Array2d_create(length: int): boolean_Array2d; overload;
function boolean_Array2d_create(length1, length2: int): boolean_Array2d; overload;
function boolean_Array2d_create(const elements: array of boolean_Array1d): boolean_Array2d; overload;
function char_Array2d_create(length: int): char_Array2d; overload;
function char_Array2d_create(length1, length2: int): char_Array2d; overload;
function char_Array2d_create(const elements: array of char_Array1d): char_Array2d; overload;
function wchar_Array2d_create(length: int): wchar_Array2d; overload;
function wchar_Array2d_create(length1, length2: int): wchar_Array2d; overload;
function wchar_Array2d_create(const elements: array of wchar_Array1d): wchar_Array2d; overload;
function byte_Array2d_create(length: int): byte_Array2d; overload;
function byte_Array2d_create(length1, length2: int): byte_Array2d; overload;
function byte_Array2d_create(const elements: array of byte_Array1d): byte_Array2d; overload;
function short_Array2d_create(length: int): short_Array2d; overload;
function short_Array2d_create(length1, length2: int): short_Array2d; overload;
function short_Array2d_create(const elements: array of short_Array1d): short_Array2d; overload;
function int_Array2d_create(length: int): int_Array2d; overload;
function int_Array2d_create(length1, length2: int): int_Array2d; overload;
function int_Array2d_create(const elements: array of int_Array1d): int_Array2d; overload;
function long_Array2d_create(length: int): long_Array2d; overload;
function long_Array2d_create(length1, length2: int): long_Array2d; overload;
function long_Array2d_create(const elements: array of long_Array1d): long_Array2d; overload;
function float_Array2d_create(length: int): float_Array2d; overload;
function float_Array2d_create(length1, length2: int): float_Array2d; overload;
function float_Array2d_create(const elements: array of float_Array1d): float_Array2d; overload;
function double_Array2d_create(length: int): double_Array2d; overload;
function double_Array2d_create(length1, length2: int): double_Array2d; overload;
function double_Array2d_create(const elements: array of double_Array1d): double_Array2d; overload;
function real_Array2d_create(length: int): real_Array2d; overload;
function real_Array2d_create(length1, length2: int): real_Array2d; overload;
function real_Array2d_create(const elements: array of real_Array1d): real_Array2d; overload;
function TObject_Array2d_create(length: int): TObject_Array2d; overload;
function TObject_Array2d_create(length1, length2: int): TObject_Array2d; overload;
function TObject_Array2d_create(const elements: array of TObject_Array1d): TObject_Array2d; overload;
function IUnknown_Array2d_create(length: int): IUnknown_Array2d; overload;
function IUnknown_Array2d_create(length1, length2: int): IUnknown_Array2d; overload;
function IUnknown_Array2d_create(const elements: array of IUnknown_Array1d): IUnknown_Array2d; overload;
function AnsiString_Array2d_create(length: int): AnsiString_Array2d; overload;
function AnsiString_Array2d_create(length1, length2: int): AnsiString_Array2d; overload;
function AnsiString_Array2d_create(const elements: array of AnsiString_Array1d): AnsiString_Array2d; overload;
function UnicodeString_Array2d_create(length: int): UnicodeString_Array2d; overload;
function UnicodeString_Array2d_create(length1, length2: int): UnicodeString_Array2d; overload;
function UnicodeString_Array2d_create(const elements: array of UnicodeString_Array1d): UnicodeString_Array2d; overload;
function arrayequalsfPrimitive(const src: boolean_Array1d; srcOffset: int; const dst: boolean_Array1d; dstOffset: int; length: int): int; overload;
function arrayequalsfPrimitive(const src: char_Array1d; srcOffset: int; const dst: char_Array1d; dstOffset: int; length: int): int; overload;
function arrayequalsfPrimitive(const src: wchar_Array1d; srcOffset: int; const dst: wchar_Array1d; dstOffset: int; length: int): int; overload;
function arrayequalsfPrimitive(const src: byte_Array1d; srcOffset: int; const dst: byte_Array1d; dstOffset: int; length: int): int; overload;
function arrayequalsfPrimitive(const src: short_Array1d; srcOffset: int; const dst: short_Array1d; dstOffset: int; length: int): int; overload;
function arrayequalsfPrimitive(const src: int_Array1d; srcOffset: int; const dst: int_Array1d; dstOffset: int; length: int): int; overload;
function arrayequalsfPrimitive(const src: long_Array1d; srcOffset: int; const dst: long_Array1d; dstOffset: int; length: int): int; overload;
function arrayequalsfInterface(const src; srcOffset: int; const dst; dstOffset: int; length: int): int;
function arrayequalsfObject(const src; srcOffset: int; const dst; dstOffset: int; length: int): int;
function arrayequalsfArray(const src; srcOffset: int; const dst; dstOffset: int; length: int): int;
function arrayequalsbPrimitive(const src: boolean_Array1d; srcOffset: int; const dst: boolean_Array1d; dstOffset: int; length: int): int; overload;
function arrayequalsbPrimitive(const src: char_Array1d; srcOffset: int; const dst: char_Array1d; dstOffset: int; length: int): int; overload;
function arrayequalsbPrimitive(const src: wchar_Array1d; srcOffset: int; const dst: wchar_Array1d; dstOffset: int; length: int): int; overload;
function arrayequalsbPrimitive(const src: byte_Array1d; srcOffset: int; const dst: byte_Array1d; dstOffset: int; length: int): int; overload;
function arrayequalsbPrimitive(const src: short_Array1d; srcOffset: int; const dst: short_Array1d; dstOffset: int; length: int): int; overload;
function arrayequalsbPrimitive(const src: int_Array1d; srcOffset: int; const dst: int_Array1d; dstOffset: int; length: int): int; overload;
function arrayequalsbPrimitive(const src: long_Array1d; srcOffset: int; const dst: long_Array1d; dstOffset: int; length: int): int; overload;
function arrayequalsbInterface(const src; srcOffset: int; const dst; dstOffset: int; length: int): int;
function arrayequalsbObject(const src; srcOffset: int; const dst; dstOffset: int; length: int): int;
function arrayequalsbArray(const src; srcOffset: int; const dst; dstOffset: int; length: int): int;
function arrayfindeqfPrimitive(const src: boolean_Array1d; offset, length: int; value: boolean): int; overload;
function arrayfindeqfPrimitive(const src: char_Array1d; offset, length: int; value: char): int; overload;
function arrayfindeqfPrimitive(const src: wchar_Array1d; offset, length: int; value: wchar): int; overload;
function arrayfindeqfPrimitive(const src: byte_Array1d; offset, length: int; value: int): int; overload;
function arrayfindeqfPrimitive(const src: short_Array1d; offset, length: int; value: int): int; overload;
function arrayfindeqfPrimitive(const src: int_Array1d; offset, length: int; value: int): int; overload;
function arrayfindeqfPrimitive(const src: long_Array1d; offset, length: int; value: long): int; overload;
function arrayfindeqfInterface(const src; offset, length: int; value: IUnknown): int;
function arrayfindeqfObject(const src; offset, length: int; value: TObject): int;
function arrayfindeqfArray(const src; offset, length: int; const value): int;
function arrayfindeqbPrimitive(const src: boolean_Array1d; offset, length: int; value: boolean): int; overload;
function arrayfindeqbPrimitive(const src: char_Array1d; offset, length: int; value: char): int; overload;
function arrayfindeqbPrimitive(const src: wchar_Array1d; offset, length: int; value: wchar): int; overload;
function arrayfindeqbPrimitive(const src: byte_Array1d; offset, length: int; value: int): int; overload;
function arrayfindeqbPrimitive(const src: short_Array1d; offset, length: int; value: int): int; overload;
function arrayfindeqbPrimitive(const src: int_Array1d; offset, length: int; value: int): int; overload;
function arrayfindeqbPrimitive(const src: long_Array1d; offset, length: int; value: long): int; overload;
function arrayfindeqbInterface(const src; offset, length: int; value: IUnknown): int;
function arrayfindeqbObject(const src; offset, length: int; value: TObject): int;
function arrayfindeqbArray(const src; offset, length: int; const value): int;
function arrayfindnefPrimitive(const src: boolean_Array1d; offset, length: int; value: boolean): int; overload;
function arrayfindnefPrimitive(const src: char_Array1d; offset, length: int; value: char): int; overload;
function arrayfindnefPrimitive(const src: wchar_Array1d; offset, length: int; value: wchar): int; overload;
function arrayfindnefPrimitive(const src: byte_Array1d; offset, length: int; value: int): int; overload;
function arrayfindnefPrimitive(const src: short_Array1d; offset, length: int; value: int): int; overload;
function arrayfindnefPrimitive(const src: int_Array1d; offset, length: int; value: int): int; overload;
function arrayfindnefPrimitive(const src: long_Array1d; offset, length: int; value: long): int; overload;
function arrayfindnefInterface(const src; offset, length: int; value: IUnknown): int;
function arrayfindnefObject(const src; offset, length: int; value: TObject): int;
function arrayfindnefArray(const src; offset, length: int; const value): int;
function arrayfindnebPrimitive(const src: boolean_Array1d; offset, length: int; value: boolean): int; overload;
function arrayfindnebPrimitive(const src: char_Array1d; offset, length: int; value: char): int; overload;
function arrayfindnebPrimitive(const src: wchar_Array1d; offset, length: int; value: wchar): int; overload;
function arrayfindnebPrimitive(const src: byte_Array1d; offset, length: int; value: int): int; overload;
function arrayfindnebPrimitive(const src: short_Array1d; offset, length: int; value: int): int; overload;
function arrayfindnebPrimitive(const src: int_Array1d; offset, length: int; value: int): int; overload;
function arrayfindnebPrimitive(const src: long_Array1d; offset, length: int; value: long): int; overload;
function arrayfindnebInterface(const src; offset, length: int; value: IUnknown): int;
function arrayfindnebObject(const src; offset, length: int; value: TObject): int;
function arrayfindnebArray(const src; offset, length: int; const value): int;
procedure arrayfillPrimitives(const dst: boolean_Array1d; offset, length: int; value: boolean); overload;
procedure arrayfillPrimitives(const dst: char_Array1d; offset, length: int; value: char); overload;
procedure arrayfillPrimitives(const dst: wchar_Array1d; offset, length: int; value: wchar); overload;
procedure arrayfillPrimitives(const dst: byte_Array1d; offset, length: int; value: int); overload;
procedure arrayfillPrimitives(const dst: short_Array1d; offset, length: int; value: int); overload;
procedure arrayfillPrimitives(const dst: int_Array1d; offset, length: int; value: int); overload;
procedure arrayfillPrimitives(const dst: long_Array1d; offset, length: int; value: long); overload;
procedure arrayfillPrimitives(const dst: float_Array1d; offset, length: int; value: float); overload;
procedure arrayfillPrimitives(const dst: double_Array1d; offset, length: int; value: double); overload;
procedure arrayfillPrimitives(const dst: real_Array1d; offset, length: int; const value: real); overload;
procedure arrayfillAnsiStrings(const dst: AnsiString_Array1d; offset, length: int; const value: AnsiString);
procedure arrayfillUnicodeStrings(const dst: UnicodeString_Array1d; offset, length: int; const value: UnicodeString);
procedure arrayfillInterfaces(const dst; offset, length: int; value: IUnknown);
procedure arrayfillObjects(const dst; offset, length: int; value: TObject);
procedure arrayfillArrays(const dst; offset, length: int; const value);
procedure arraycopyPrimitives(const src: boolean_Array1d; srcOffset: int; const dst: boolean_Array1d; dstOffset: int; length: int); overload;
procedure arraycopyPrimitives(const src: char_Array1d; srcOffset: int; const dst: char_Array1d; dstOffset: int; length: int); overload;
procedure arraycopyPrimitives(const src: wchar_Array1d; srcOffset: int; const dst: wchar_Array1d; dstOffset: int; length: int); overload;
procedure arraycopyPrimitives(const src: byte_Array1d; srcOffset: int; const dst: byte_Array1d; dstOffset: int; length: int); overload;
procedure arraycopyPrimitives(const src: short_Array1d; srcOffset: int; const dst: short_Array1d; dstOffset: int; length: int); overload;
procedure arraycopyPrimitives(const src: int_Array1d; srcOffset: int; const dst: int_Array1d; dstOffset: int; length: int); overload;
procedure arraycopyPrimitives(const src: long_Array1d; srcOffset: int; const dst: long_Array1d; dstOffset: int; length: int); overload;
procedure arraycopyPrimitives(const src: float_Array1d; srcOffset: int; const dst: float_Array1d; dstOffset: int; length: int); overload;
procedure arraycopyPrimitives(const src: double_Array1d; srcOffset: int; const dst: double_Array1d; dstOffset: int; length: int); overload;
procedure arraycopyPrimitives(const src: real_Array1d; srcOffset: int; const dst: real_Array1d; dstOffset: int; length: int); overload;
procedure arraycopyAnsiStrings(const src: AnsiString_Array1d; srcOffset: int; const dst: AnsiString_Array1d; dstOffset: int; length: int);
procedure arraycopyUnicodeStrings(const src: UnicodeString_Array1d; srcOffset: int; const dst: UnicodeString_Array1d; dstOffset: int; length: int);
procedure arraycopyInterfaces(const src; srcOffset: int; const dst; dstOffset: int; length: int);
procedure arraycopyObjects(const src; srcOffset: int; const dst; dstOffset: int; length: int);
procedure arraycopyArrays(const src; srcOffset: int; const dst; dstOffset: int; length: int);
procedure arrayCheckBounds(const method: AnsiString; arrayLength, offset, length: int);
procedure synchronized(m: Monitor);
procedure synchronizedEnd(m: Monitor);
procedure classInfoAdd(const typeInfos: array of Pointer);
{%endregion}
{%region operator }
operator :=(value: byte): real;
operator :=(value: short): real;
operator :=(value: int): real;
operator :=(value: long): real;
operator :=(value: float): real;
operator :=(value: double): 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;
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 value: real): real;
operator -(const value: real): real;
{%endregion}
implementation
{%region private }
const { значения для TObjectExtended }
TM_FIELD = int(0);
TM_SPECIAL = int(1);
TM_VIRTUAL = int(2);
TM_CONST = int(3);
const { значения для Monitor }
RUNNING = int(1);
WAITING = int(2);
SUSPENDED = int(3);
type
PFXContext = ^FXContext;
Scheduler = class;
Information = class;
PrimitiveInformation = class;
GuidInformation = class;
ClassInformation = class;
InterfaceInformation = class;
PropertyInformation = class;
TypeEnumeration = class;
long2 = packed array [0..1] of long;
{ Task[] } Task_Array1d = packed array of Task;
{ Pointer[] } Pointer_Array1d = packed array of Pointer;
{ PTypeInfo[] } PTypeInfo_Array1d = packed array of PTypeInfo;
{$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; rsvd00: byte;
fop: short;
fip: long;
fdp: long;
mxcsr: int;
mxcsrMask: int;
st0: real; rsvd01: packed array [0..5] of byte;
st1: real; rsvd02: packed array [0..5] of byte;
st2: real; rsvd03: packed array [0..5] of byte;
st3: real; rsvd04: packed array [0..5] of byte;
st4: real; rsvd05: packed array [0..5] of byte;
st5: real; rsvd06: packed array [0..5] of byte;
st6: real; rsvd07: packed array [0..5] of byte;
st7: real; rsvd08: packed array [0..5] of byte;
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;
rsvd09: packed array [0..47] of byte;
available: packed array [0..47] of byte;
end;
RealStruct = packed record
significand: long;
exponent: short;
end;
Scheduler = class(_Object, Runnable)
public
constructor create();
destructor destroy; override;
function indexOf(t: Task): int;
function cancel(t: Task): boolean;
function pop(): Task;
procedure push(t: Task);
procedure updateTimer();
procedure freeTimer();
procedure run();
private
fCount: int;
fQueue: Task_Array1d;
fTimer: THandle;
fSynchronize: TRTLCriticalSection;
end;
Information = class(RefCountInterfacedObject, _Class)
public
function isPrimitive(): boolean; virtual;
function isInterface(): boolean; virtual; abstract;
function isInstance(ref: TObject): boolean;
function isAssignableFrom(cls: _Class): boolean;
function getPrimitiveType(): int; virtual;
function getProperty(const name: AnsiString): _Property; virtual;
function getSuperclass(): _Class; virtual;
function getInterfaces(): _Class_Array1d; virtual;
function getProperties(): _Property_Array1d; virtual;
function getCanonicalName(): AnsiString; virtual; abstract;
function getSimpleName(): AnsiString; virtual; abstract;
function getUnitName(): AnsiString; virtual;
function createInstance(): DynamicalyAllocatedObject; virtual;
protected
function isInheritedFrom(const cls: Information): boolean; virtual;
function isInterfaceImplements(const cls: Information): boolean; virtual;
end;
PrimitiveInformation = class(Information)
public
constructor create(info: int; const name: AnsiString = '');
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function isPrimitive(): boolean; override;
function isInterface(): boolean; override;
function getPrimitiveType(): int; override;
function getCanonicalName(): AnsiString; override;
function getSimpleName(): AnsiString; override;
private
custom: boolean;
info: int;
name: AnsiString;
end;
GuidInformation = class(Information)
public
constructor create(const info: TGuid);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function isInterface(): boolean; override;
function getCanonicalName(): AnsiString; override;
function getSimpleName(): AnsiString; override;
private
info: TGuid;
end;
ClassInformation = class(Information)
private
class function typeInfoToLangType(tinfo: PTypeInfo): int; static;
class function propInfoToProperty(pinfo: PPropInfo): _Property; static;
public
constructor create(info: TClass);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function isInterface(): boolean; override;
function getProperty(const name: AnsiString): _Property; override;
function getSuperclass(): _Class; override;
function getInterfaces(): _Class_Array1d; override;
function getProperties(): _Property_Array1d; override;
function getCanonicalName(): AnsiString; override;
function getSimpleName(): AnsiString; override;
function getUnitName(): AnsiString; override;
function createInstance(): DynamicalyAllocatedObject; override;
protected
function isInheritedFrom(const cls: Information): boolean; override;
function isInterfaceImplements(const cls: Information): boolean; override;
private
info: TClass;
end;
InterfaceInformation = class(Information)
public
constructor create(info: PTypeInfo);
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function toString(): AnsiString; override;
function isInterface(): boolean; override;
function getSuperclass(): _Class; override;
function getInterfaces(): _Class_Array1d; override;
function getCanonicalName(): AnsiString; override;
function getSimpleName(): AnsiString; override;
function getUnitName(): AnsiString; override;
protected
function isInheritedFrom(const cls: Information): boolean; override;
function isInterfaceImplements(const cls: Information): boolean; override;
private
info: PTypeInfo;
end;
PropertyInformation = class(RefCountInterfacedObject, _Property)
public
constructor create(readable, writeable, storeable: boolean; &type: _Class; const name: AnsiString);
function isReadable(): boolean;
function isWriteable(): boolean;
function isStoreable(): boolean;
function getType(): _Class;
function getName(): AnsiString;
private
flags: int;
&type: _Class;
name: AnsiString;
end;
TypeEnumeration = class(_Object)
public
constructor create(info: PTypeInfo);
function hasMoreElements(): boolean;
function nextElement(): _Class;
private
info: PTypeInfo;
end;
var
constantPoolLong: packed array [0..1] of long = (
$000000007fffffff, $7fffffffffffffff
);
constantPoolFloat: packed array [0..0] of float = (
2.14748365e+09
);
constantPoolDouble: packed array [0..1] of double = (
2.14748364800000000e+009, 9.22337203685477581e+018
);
typeInfosLength: int;
typeInfosData: PTypeInfo_Array1d;
primitivesData: _Class_Array1d;
defaultContext: FXContext;
realRepresenter: RealValueRepresenter;
floatRepresenter: RealValueRepresenter;
doubleRepresenter: RealValueRepresenter;
schedulerInstance: Scheduler;
{$IFDEF WINDOWS}
previousGetExceptionObject: FunctionGetExceptionObject;
previousGetExceptionClass: FunctionGetExceptionClass;
{$ENDIF}
previousExceptionHandler: TErrorProc;
outOfMemory: MemoryError;
invalidPointer: MemoryError;
{%endregion}
{%region routine }
procedure fxcontextLoadFrom(context: PFXContext); assembler; nostackframe;
asm
db $48
fxrstor [rcx]
end;
procedure fxcontextSaveTo(context: PFXContext); assembler; nostackframe;
asm
db $48
fxsave [rcx]
end;
function interlockedIncrement(intField: Pointer): int; assembler; nostackframe;
asm
mov eax, $01
lock xadd [rcx], eax
inc eax
end;
function interlockedDecrement(intField: Pointer): int; assembler; nostackframe;
asm
mov eax, -$01
lock xadd [rcx], eax
dec eax
end;
function round(const value: real): long; assembler; nostackframe;
asm
fld tbyte[rcx]
fild qword[rip+constantPoolLong-@0+$08]
@0: fcomip st, st(1)
jnp @1
ffree st
fincstp
xor eax, eax
ret
@1: ja @3
ffree st
fincstp
mov rax, [rip+constantPoolLong-@2+$08]
@2: ret
@3: lea rsp, [rsp-$08]
fistp qword[rsp]
pop rax
end;
function log2(const value: real): real; assembler; nostackframe;
asm
fld1
fld tbyte[rdx]
fyl2x
fstp tbyte[rcx]
end;
function getDigit(character: char; radix: int): int;
begin
result := -1;
if (radix >= MIN_RADIX) and (radix <= MAX_RADIX) then begin
if (character >= '0') and (character <= '9') then begin
result := int(character) - int('0');
end else
if (character >= 'a') and (character <= 'z') or (character >= 'A') and (character <= 'Z') then begin
result := (int(character) and $1f) + 9;
end;
end;
if result >= radix then begin
result := -1;
end;
end;
function getDigitRepresentation(digit: int): char;
begin
if (digit >= $00) and (digit < $0a) then begin
result := char(digit + int('0'));
end else
if (digit >= $0a) and (digit < MAX_RADIX) then begin
result := char(digit + (int('a') - $0a));
end else begin
result := '?';
end;
end;
function charIsDigit(c: char): boolean;
begin
result := (c >= '0') and (c <= '9');
end;
function charIsDigit(c: wchar): boolean;
begin
result := (c >= '0') and (c <= '9');
end;
function charIsLowerCase(c: char): boolean;
begin
result := (c >= 'a') and (c <= 'z');
end;
function charIsLowerCase(c: wchar): boolean;
begin
result := (c >= 'a') and (c <= 'z') or (c >= #$00df) and (c <= #$00f6) or (c >= #$00f8) and (c <= #$00ff) or (c >= #$0430) and (c <= #$045f);
end;
function charIsUpperCase(c: char): boolean;
begin
result := (c >= 'A') and (c <= 'Z');
end;
function charIsUpperCase(c: wchar): boolean;
begin
result := (c >= 'A') and (c <= 'Z') or (c >= #$00c0) and (c <= #$00d6) or (c >= #$00d8) and (c <= #$00de) or (c >= #$0400) and (c <= #$042f);
end;
function charToLowerCase(c: char): char;
begin
if charIsUpperCase(c) then begin
result := char(int(c) + $20);
end else begin
result := c;
end;
end;
function charToLowerCase(c: wchar): wchar;
begin
if charIsUpperCase(c) then begin
if (c >= #$0400) and (c <= #$040f) then begin
result := wchar(int(c) + $0050);
end else begin
result := wchar(int(c) + $0020);
end;
end else begin
result := c;
end;
end;
function charToUpperCase(c: char): char;
begin
if charIsLowerCase(c) then begin
result := char(int(c) - $20);
end else begin
result := c;
end;
end;
function charToUpperCase(c: wchar): wchar;
begin
if charIsLowerCase(c) then begin
if (c >= #$0450) and (c <= #$045f) then begin
result := wchar(int(c) - $0050);
end else begin
result := wchar(int(c) - $0020);
end;
end else begin
result := c;
end;
end;
function byteParse(const str: AnsiString; radix: int = 10): byte;
var
value: int;
begin
value := intParse(str, radix);
if (value < BYTE_MIN_VALUE) or (value > BYTE_MAX_VALUE) then begin
raise NumberFormatException.create('byteParse: ' + msgIllegalNumberFormat);
end;
result := byte(value);
end;
function shortByteSwap(value: short): short; assembler; nostackframe;
asm
mov ax, cx
xchg al, ah
end;
function shortParse(const str: AnsiString; radix: int = 10): short;
var
value: int;
begin
value := intParse(str, radix);
if (value < SHORT_MIN_VALUE) or (value > SHORT_MAX_VALUE) then begin
raise NumberFormatException.create('shortParse: ' + msgIllegalNumberFormat);
end;
result := short(value);
end;
function intBitsToFloat(bits: int): float; assembler; nostackframe;
asm
movd xmm0, ecx
end;
function intByteSwap(value: int): int; assembler; nostackframe;
asm
mov eax, ecx
bswap eax
end;
function intSar(value: int; bits: int): int; assembler; nostackframe;
asm
mov eax, ecx
mov ecx, edx
sar eax, cl
end;
function intAbs(value: int): int; inline;
begin
if value < 0 then begin
result := -value;
end else begin
result := value;
end;
end;
function intMax(value1, value2: int): int; inline;
begin
if value1 < value2 then begin
result := value2;
end else begin
result := value1;
end;
end;
function intMin(value1, value2: int): int; inline;
begin
if value1 < value2 then begin
result := value1;
end else begin
result := value2;
end;
end;
function intBound(minimum, value, maximum: int): int; inline;
begin
result := intMin(intMax(minimum, value), maximum);
end;
function intParse(const str: AnsiString; radix: int = 10): int;
var
negative: boolean;
i: int;
len: int;
limit: int;
digit: int;
mulmin: int;
begin
len := length(str);
if len <= 0 then begin
raise NumberFormatException.create('intParse: ' + msgIllegalNumberFormat);
end;
if radix > MAX_RADIX then begin
raise NumberFormatException.create('intParse: ' + msgIllegalRadix);
end;
if radix < MIN_RADIX then begin
raise NumberFormatException.create('intParse: ' + msgIllegalRadix);
end;
result := 0;
i := 0;
if str[1] = '-' then begin
inc(i);
negative := true;
limit := int($80000000);
end else begin
negative := false;
limit := int($80000001);
end;
mulmin := limit div radix;
if i < len then begin
digit := getDigit(str[i + 1], radix);
inc(i);
if digit < 0 then begin
raise NumberFormatException.create('intParse: ' + msgIllegalNumberFormat);
end;
result := -digit;
end;
while i < len do begin
digit := getDigit(str[i + 1], radix);
inc(i);
if (digit < 0) or (result < mulmin) then begin
raise NumberFormatException.create('intParse: ' + msgIllegalNumberFormat);
end;
result := result * radix;
if result < limit + digit then begin
raise NumberFormatException.create('intParse: ' + msgIllegalNumberFormat);
end;
result := result - digit;
end;
if negative then begin
if i < 2 then begin
raise NumberFormatException.create('intParse: ' + msgIllegalNumberFormat);
end;
exit;
end;
result := -result;
end;
function intToString(value: int; radix: int = 10): AnsiString;
var
negative: boolean;
i: int;
len: int;
negradix: int;
buf: char_Array1d;
begin
negative := value < 0;
i := 32;
len := i + 1;
buf := char_Array1d_create(len);
if (radix > MAX_RADIX) or (radix < MIN_RADIX) then radix := 10;
if not negative then value := -value;
negradix := -radix;
while value <= negradix do begin
buf[i] := getDigitRepresentation(-(value mod radix));
value := value div radix;
dec(i);
end;
buf[i] := getDigitRepresentation(-value);
if negative then begin
dec(i);
buf[i] := '-';
end;
result := AnsiString_create(buf, i, len - i);
end;
function intToUnsignedString(value: int; shift: int): AnsiString;
var
i: int;
len: int;
mask: int;
buf: char_Array1d;
begin
i := 32;
len := i;
mask := (1 shl shift) - 1;
buf := char_Array1d_create(len);
repeat
dec(i);
buf[i] := getDigitRepresentation(value and mask);
value := value shr shift;
until value = 0;
result := AnsiString_create(buf, i, len - i);
end;
function intToBinaryString(value: int): AnsiString;
begin
result := intToUnsignedString(value, 1);
end;
function intToOctalString(value: int): AnsiString;
begin
result := intToUnsignedString(value, 3);
end;
function intToHexString(value: int): AnsiString;
begin
result := intToUnsignedString(value, 4);
end;
function intToFloat(value: int): float; assembler; nostackframe;
asm
cvtsi2ss xmm0, ecx
end;
function intToDouble(value: int): double; assembler; nostackframe;
asm
cvtsi2sd xmm0, ecx
end;
function longBitsToDouble(bits: long): double; assembler; nostackframe;
asm
movq xmm0, rcx
end;
function longByteSwap(value: long): long; assembler; nostackframe;
asm
mov rax, rcx
bswap rax
end;
function longSar(value: long; bits: int): long; assembler; nostackframe;
asm
mov rax, rcx
mov ecx, edx
sar rax, cl
end;
function longAbs(value: long): long; inline;
begin
if value < 0 then begin
result := -value;
end else begin
result := value;
end;
end;
function longMax(value1, value2: long): long; inline;
begin
if value1 < value2 then begin
result := value2;
end else begin
result := value1;
end;
end;
function longMin(value1, value2: long): long; inline;
begin
if value1 < value2 then begin
result := value1;
end else begin
result := value2;
end;
end;
function longBound(minimum, value, maximum: long): long; inline;
begin
result := longMin(longMax(minimum, value), maximum);
end;
function longParse(const str: AnsiString; radix: int = 10): long;
var
negative: boolean;
i: int;
len: int;
limit: long;
digit: long;
mulmin: long;
begin
len := length(str);
if len <= 0 then begin
raise NumberFormatException.create('longParse: ' + msgIllegalNumberFormat);
end;
if radix > MAX_RADIX then begin
raise NumberFormatException.create('longParse: ' + msgIllegalRadix);
end;
if radix < MIN_RADIX then begin
raise NumberFormatException.create('longParse: ' + msgIllegalRadix);
end;
result := 0;
i := 0;
if str[1] = '-' then begin
inc(i);
negative := true;
limit := $8000000000000000;
end else begin
negative := false;
limit := $8000000000000001;
end;
mulmin := limit div radix;
if i < len then begin
digit := getDigit(str[i + 1], radix);
inc(i);
if digit < 0 then begin
raise NumberFormatException.create('longParse: ' + msgIllegalNumberFormat);
end;
result := -digit;
end;
while i < len do begin
digit := getDigit(str[i + 1], radix);
inc(i);
if (digit < 0) or (result < mulmin) then begin
raise NumberFormatException.create('longParse: ' + msgIllegalNumberFormat);
end;
result := result * radix;
if result < limit + digit then begin
raise NumberFormatException.create('longParse: ' + msgIllegalNumberFormat);
end;
result := result - digit;
end;
if negative then begin
if i < 2 then begin
raise NumberFormatException.create('longParse: ' + msgIllegalNumberFormat);
end;
exit;
end;
result := -result;
end;
function longToString(value: long; radix: int = 10): AnsiString;
var
negative: boolean;
i: int;
len: int;
posradix: long;
negradix: long;
buf: char_Array1d;
begin
negative := value < 0;
i := 64;
len := i + 1;
buf := char_Array1d_create(len);
if (radix > MAX_RADIX) or (radix < MIN_RADIX) then radix := 10;
if not negative then value := -value;
posradix := radix;
negradix := -posradix;
while value <= negradix do begin
buf[i] := getDigitRepresentation(int(-(value mod posradix)));
value := value div posradix;
dec(i);
end;
buf[i] := getDigitRepresentation(int(-value));
if negative then begin
dec(i);
buf[i] := '-';
end;
result := AnsiString_create(buf, i, len - i);
end;
function longToUnsignedString(value: long; shift: int): AnsiString;
var
i: int;
len: int;
mask: long;
buf: char_Array1d;
begin
i := 64;
len := i;
mask := (1 shl shift) - 1;
buf := char_Array1d_create(len);
repeat
dec(i);
buf[i] := getDigitRepresentation(int(value and mask));
value := value shr shift;
until value = 0;
result := AnsiString_create(buf, i, len - i);
end;
function longToBinaryString(value: long): AnsiString;
begin
result := longToUnsignedString(value, 1);
end;
function longToOctalString(value: long): AnsiString;
begin
result := longToUnsignedString(value, 3);
end;
function longToHexString(value: long): AnsiString;
begin
result := longToUnsignedString(value, 4);
end;
function longToFloat(value: long): float; assembler; nostackframe;
asm
cvtsi2ss xmm0, rcx
end;
function longToDouble(value: long): double; assembler; nostackframe;
asm
cvtsi2sd xmm0, rcx
end;
function ulongCmp(uvalue1, uvalue2: long): int; assembler; nostackframe;
asm
cmp rcx, rdx
jb @lt
je @eq
mov eax, $01
ret
@lt: mov eax, -$01
ret
@eq: xor eax, eax
end;
function ulongDiv(uvalue1, uvalue2: long): long; assembler; nostackframe;
asm
mov rax, rcx
mov rcx, rdx
xor rdx, rdx
div rcx
end;
function ulongRem(uvalue1, uvalue2: long): long; assembler; nostackframe;
asm
mov rax, rcx
mov rcx, rdx
xor rdx, rdx
div rcx
mov rax, rdx
end;
function ulongToReal(uvalue: long): real; assembler; nostackframe;
asm
cmp rdx, $00
jl @0
push rdx
fild qword[rsp]
jmp @exit
@0: btr rdx, $3f
push rdx
fild qword[rsp]
fld qword[rip+constantPoolDouble-@1+$08]
@1: faddp st(1), st
@exit: fstp tbyte[rcx]
lea rsp, [rsp+$08]
end;
function floatIsNaN(value: float): boolean;
begin
result := value <> value;
end;
function floatIsInfinite(value: float): boolean;
begin
result := (value = FLOAT_POSITIVE_INFINITY) or (value = FLOAT_NEGATIVE_INFINITY);
end;
function floatToIntBits(value: float): int; assembler; nostackframe;
asm
movd eax, xmm0
end;
function floatCmpl(value1, value2: float): int; assembler; nostackframe;
asm
comiss xmm0, xmm1
jp @lt
jc @lt
jz @eq
@gt: mov eax, $01
ret
@lt: mov eax, -$01
ret
@eq: xor eax, eax
end;
function floatCmpg(value1, value2: float): int; assembler; nostackframe;
asm
comiss xmm0, xmm1
jp @gt
jc @lt
jz @eq
@gt: mov eax, $01
ret
@lt: mov eax, -$01
ret
@eq: xor eax, eax
end;
function floatAbs(value: float): float; assembler; nostackframe;
asm
mov eax, $7fffffff
movd xmm1, eax
pand xmm0, xmm1
end;
function floatMax(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 (floatToIntBits(value1) = INT_MIN_VALUE) or (value1 < value2) then begin
result := value2;
exit;
end;
result := value1;
end;
function floatMin(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 (floatToIntBits(value2) = INT_MIN_VALUE) or (value1 > value2) then begin
result := value2;
exit;
end;
result := value1;
end;
function floatMod(value1, value2: float): float; assembler; nostackframe;
asm
lea rsp, [rsp-$10]
movss [rsp], xmm0
movss [rsp+$08], xmm1
fld dword[rsp+$08]
fld dword[rsp]
@loop: fprem
fnstsw ax
test eax, $0400
jnz @loop
fstp st(1)
fstp dword[rsp]
movss xmm0, [rsp]
lea rsp, [rsp+$10]
end;
function floatBound(minimum, value, maximum: float): float;
begin
result := floatMin(floatMax(minimum, value), maximum);
end;
function floatParse(const str: AnsiString): float;
begin
result := floatRepresenter.parseFloat(str);
end;
function floatToString(value: float): AnsiString;
begin
result := floatRepresenter.toString(value);
end;
function floatToInt(value: float): int; assembler; nostackframe;
asm
movss xmm1, xmm0
movss xmm2, dword[rip+constantPoolFloat-@0+$00]
@0: movss xmm3, xmm0
cvttps2dq xmm0, xmm0
cmpss xmm1, xmm1, $07
cmpss xmm2, xmm3, $02
paddd xmm0, xmm2
pand xmm0, xmm1
movd eax, xmm0
end;
function floatToLong(value: float): long; assembler; nostackframe;
asm
cvtss2sd xmm0, xmm0
movsd xmm1, xmm0
movsd xmm2, qword[rip+constantPoolDouble-@0+$08]
@0: 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;
function floatToDouble(value: float): double; assembler; nostackframe;
asm
cvtss2sd xmm0, xmm0
end;
function doubleIsNaN(value: double): boolean;
begin
result := value <> value;
end;
function doubleIsInfinite(value: double): boolean;
begin
result := (value = DOUBLE_POSITIVE_INFINITY) or (value = DOUBLE_NEGATIVE_INFINITY);
end;
function doubleToLongBits(value: double): long; assembler; nostackframe;
asm
movq rax, xmm0
end;
function doubleCmpl(value1, value2: double): int; assembler; nostackframe;
asm
comisd xmm0, xmm1
jp @lt
jc @lt
jz @eq
@gt: mov eax, $01
ret
@lt: mov eax, -$01
ret
@eq: xor eax, eax
end;
function doubleCmpg(value1, value2: double): int; assembler; nostackframe;
asm
comisd xmm0, xmm1
jp @gt
jc @lt
jz @eq
@gt: mov eax, $01
ret
@lt: mov eax, -$01
ret
@eq: xor eax, eax
end;
function doubleAbs(value: double): double; assembler; nostackframe;
asm
mov rax, [rip+constantPoolLong-@0+$08]
@0: movq xmm1, rax
pand xmm0, xmm1
end;
function doubleMax(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 (doubleToLongBits(value1) = LONG_MIN_VALUE) or (value1 < value2) then begin
result := value2;
exit;
end;
result := value1;
end;
function doubleMin(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 (doubleToLongBits(value2) = LONG_MIN_VALUE) or (value1 > value2) then begin
result := value2;
exit;
end;
result := value1;
end;
function doubleMod(value1, value2: double): double; assembler; nostackframe;
asm
lea rsp, [rsp-$10]
movsd [rsp], xmm0
movsd [rsp+$08], xmm1
fld qword[rsp+$08]
fld qword[rsp]
@loop: fprem
fnstsw ax
test eax, $0400
jnz @loop
fstp st(1)
fstp qword[rsp]
movsd xmm0, [rsp]
lea rsp, [rsp+$10]
end;
function doubleBound(minimum, value, maximum: double): double;
begin
result := doubleMin(doubleMax(minimum, value), maximum);
end;
function doubleParse(const str: AnsiString): double;
begin
result := doubleRepresenter.parseDouble(str);
end;
function doubleToString(value: double): AnsiString;
begin
result := doubleRepresenter.toString(value);
end;
function doubleToInt(value: double): int; assembler; nostackframe;
asm
movsd xmm1, xmm0
movsd xmm2, qword[rip+constantPoolDouble-@0+$00]
@0: movsd xmm3, xmm0
cvttpd2dq xmm0, xmm0
cmpsd xmm1, xmm1, $07
cmpsd xmm2, xmm3, $02
paddd xmm0, xmm2
pand xmm0, xmm1
movd eax, xmm0
end;
function doubleToLong(value: double): long; assembler; nostackframe;
asm
movsd xmm1, xmm0
movsd xmm2, qword[rip+constantPoolDouble-@0+$08]
@0: 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;
function doubleToFloat(value: double): float; assembler; nostackframe;
asm
cvtsd2ss xmm0, xmm0
end;
function REAL_NAN: real; inline;
begin
result := realBuild($ffff, $c000000000000000);
end;
function REAL_POSITIVE_INFINITY: real; inline;
begin
result := realBuild($7fff, $8000000000000000);
end;
function REAL_NEGATIVE_INFINITY: real; inline;
begin
result := realBuild($ffff, $8000000000000000);
end;
function REAL_MIN_VALUE: real; inline;
begin
result := realBuild($0000, $0000000000000001);
end;
function REAL_MAX_VALUE: real; inline;
begin
result := realBuild($7ffe, $ffffffffffffffff);
end;
function realIsNaN(const value: real): boolean;
begin
result := value <> value;
end;
function realIsInfinite(const value: real): boolean;
begin
result := (value = REAL_POSITIVE_INFINITY) or (value = REAL_NEGATIVE_INFINITY);
end;
function realBuild(exponent: int; significand: long): real; inline;
begin
RealStruct(result).significand := significand;
RealStruct(result).exponent := short(exponent);
end;
function realSignificand(const value: real): long; inline;
begin
result := RealStruct(value).significand;
end;
function realExponent(const value: real): int; inline;
begin
result := RealStruct(value).exponent;
end;
function realCmpl(const value1, value2: real): int; assembler; nostackframe;
asm
fld tbyte[rdx]
fld tbyte[rcx]
fcomip st, st(1)
ffree st
fincstp
jp @lt
jc @lt
jz @eq
@gt: mov eax, $01
ret
@lt: mov eax, -$01
ret
@eq: xor eax, eax
end;
function realCmpg(const value1, value2: real): int; assembler; nostackframe;
asm
fld tbyte[rdx]
fld tbyte[rcx]
fcomip st, st(1)
ffree st
fincstp
jp @gt
jc @lt
jz @eq
@gt: mov eax, $01
ret
@lt: mov eax, -$01
ret
@eq: xor eax, eax
end;
function realAbs(const value: real): real; assembler; nostackframe;
asm
mov r8, [rdx]
movsx eax, word[rdx+$08]
and eax, $7fff
mov [rcx], r8
mov [rcx+$08], ax
end;
function realMax(const 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 (realExponent(value1) = SHORT_MIN_VALUE) and (realSignificand(value1) = 0) or (value1 < value2) then begin
result := value2;
exit;
end;
result := value1;
end;
function realMin(const 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 (realExponent(value2) = SHORT_MIN_VALUE) and (realSignificand(value2) = 0) or (value1 > value2) then begin
result := value2;
exit;
end;
result := value1;
end;
function realMod(const value1, value2: real): real; assembler; nostackframe;
asm
fld tbyte[r8]
fld tbyte[rdx]
@loop: fprem
fnstsw ax
test eax, $0400
jnz @loop
fstp st(1)
fstp tbyte[rcx]
end;
function realBound(const minimum, value, maximum: real): real;
begin
result := realMin(realMax(minimum, value), maximum);
end;
function realParse(const str: AnsiString): real;
begin
result := realRepresenter.parseReal(str);
end;
function realToString(const value: real): AnsiString;
begin
result := realRepresenter.toString(value);
end;
function realToInt(const value: real): int; assembler; nostackframe;
asm
fld tbyte[rcx]
fild qword[rip+constantPoolLong-@0+$00]
@0: fcomip st, st(1)
jnp @1
ffree st
fincstp
xor eax, eax
ret
@1: ja @3
ffree st
fincstp
mov eax, $7fffffff
ret
@3: lea rsp, [rsp-$08]
fisttp dword[rsp]
pop rax
end;
function realToLong(const value: real): long; assembler; nostackframe;
asm
fld tbyte[rcx]
fild qword[rip+constantPoolLong-@0+$08]
@0: fcomip st, st(1)
jnp @1
ffree st
fincstp
xor eax, eax
ret
@1: ja @3
ffree st
fincstp
mov rax, [rip+constantPoolLong-@2+$08]
@2: ret
@3: lea rsp, [rsp-$08]
fisttp qword[rsp]
pop rax
end;
function realToFloat(const value: real): float; assembler; nostackframe;
asm
lea rsp, [rsp-$08]
fld tbyte[rcx]
fstp dword[rsp]
movss xmm0, [rsp]
lea rsp, [rsp+$08]
end;
function realToDouble(const value: real): double; assembler; nostackframe;
asm
lea rsp, [rsp-$08]
fld tbyte[rcx]
fstp qword[rsp]
movsd xmm0, [rsp]
lea rsp, [rsp+$08]
end;
function stringToUTF8(const str: UnicodeString): AnsiString;
var
i: int;
slen: int;
rlen: int;
capa: int;
code: int;
char1: int;
char2: int;
buf: byte_Array1d;
begin
slen := length(str);
if slen <= 0 then begin
result := '';
exit;
end;
rlen := 0;
capa := int(longMin(long(slen) shl 2, INT_MAX_VALUE));
buf := byte_Array1d_create(capa);
i := 0;
while i < slen do begin
char1 := int(str[i + 1]);
inc(i);
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 i < slen then begin
char2 := int(str[i + 1]);
if (char2 < $dc00) or (char2 >= $e000) then begin
char2 := 0;
end else begin
inc(i);
end;
end;
code := ((char1 and $03ff) shl 10) + (char2 and $03ff) + $010000;
end;
if (code >= $000001) and (code < $000080) then begin
if rlen >= capa then break;
buf[rlen] := byte(code);
inc(rlen);
end else
if (code >= $000000) and (code < $000800) then begin
if rlen >= capa - 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 >= capa - 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 >= capa - 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 stringToUTF16(const str: AnsiString): UnicodeString;
var
i: int;
slen: int;
rlen: int;
capa: int;
code: int;
char1: int;
char2: int;
char3: int;
char4: int;
buf: short_Array1d;
begin
slen := length(str);
if slen <= 0 then begin
result := '';
exit;
end;
rlen := 0;
capa := int(longMin(long(slen) shl 1, INT_MAX_VALUE));
buf := short_Array1d_create(capa);
i := 0;
while i < slen do begin
char1 := int(str[i + 1]);
inc(i);
if (char1 >= $00) and (char1 < $80) then begin
if rlen >= capa then break;
buf[rlen] := short(char1);
inc(rlen);
end else
if (char1 >= $c0) and (char1 < $e0) then begin
if rlen >= capa then break;
char2 := 0;
if i < slen then begin
char2 := int(str[i + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(i);
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 i < slen then begin
char2 := int(str[i + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(i);
end;
end;
if i < slen then begin
char3 := int(str[i + 1]);
if (char3 and $c0) <> $80 then begin
char3 := 0;
end else begin
inc(i);
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 >= capa 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 i < slen then begin
char2 := int(str[i + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(i);
end;
end;
if i < slen then begin
char3 := int(str[i + 1]);
if (char3 and $c0) <> $80 then begin
char3 := 0;
end else begin
inc(i);
end;
end;
if i < slen then begin
char4 := int(str[i + 1]);
if (char4 and $c0) <> $80 then begin
char4 := 0;
end else begin
inc(i);
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 >= capa then break;
buf[rlen] := short(code);
inc(rlen);
end else
if (code >= $010000) and (code < $110000) then begin
if rlen >= capa - 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 stringBuildUTF8(const charCodes: int_Array1d; offset, length: int): AnsiString;
var
i: int;
rlen: int;
capa: int;
code: int;
buf: byte_Array1d;
begin
arrayCheckBounds('stringBuildUTF8', system.length(charCodes), offset, length);
rlen := 0;
capa := int(longMin(long(length) * 6, INT_MAX_VALUE));
buf := byte_Array1d_create(capa);
for i := offset to offset + length - 1 do begin
code := charCodes[i];
if (code >= $00000001) and (code < $00000080) then begin
if rlen >= capa then break;
buf[rlen] := byte(code);
inc(rlen);
end else
if (code >= $00000000) and (code < $00000800) then begin
if rlen >= capa - 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 >= $00000800) and (code < $00010000) then begin
if rlen >= capa - 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 >= $00010000) and (code < $00200000) then begin
if rlen >= capa - 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 else
if (code >= $00200000) and (code < $04000000) then begin
if rlen >= capa - 4 then break;
buf[rlen] := byte($f8 + (code shr 24));
buf[rlen + 1] := byte($80 + ((code shr 18) and $3f));
buf[rlen + 2] := byte($80 + ((code shr 12) and $3f));
buf[rlen + 3] := byte($80 + ((code shr 6) and $3f));
buf[rlen + 4] := byte($80 + (code and $3f));
inc(rlen, 5);
end else begin
if rlen >= capa - 5 then break;
buf[rlen] := byte($fc + (code shr 30));
buf[rlen + 1] := byte($80 + ((code shr 24) and $3f));
buf[rlen + 2] := byte($80 + ((code shr 18) and $3f));
buf[rlen + 3] := byte($80 + ((code shr 12) and $3f));
buf[rlen + 4] := byte($80 + ((code shr 6) and $3f));
buf[rlen + 5] := byte($80 + (code and $3f));
inc(rlen, 6);
end;
end;
result := AnsiString_create(buf, 0, rlen);
end;
function stringBuildUTF16(const charCodes: int_Array1d; offset, length: int): UnicodeString;
var
i: int;
rlen: int;
capa: int;
code: int;
buf: short_Array1d;
begin
arrayCheckBounds('stringBuildUTF16', system.length(charCodes), offset, length);
rlen := 0;
capa := int(longMin(long(length) shl 1, INT_MAX_VALUE));
buf := short_Array1d_create(capa);
for i := offset to offset + length - 1 do begin
code := charCodes[i];
if (code >= $000000) and (code < $00d800) or (code >= $00e000) and (code < $010000) then begin
if rlen >= capa then break;
buf[rlen] := short(code);
inc(rlen);
end else
if (code >= $010000) and (code < $110000) then begin
if rlen >= capa - 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;
result := UnicodeString_create(buf, 0, rlen);
end;
function stringToCharCodes(const str: AnsiString): int_Array1d;
var
i: int;
slen: int;
rlen: int;
char1: int;
char2: int;
char3: int;
char4: int;
char5: int;
char6: int;
buf: int_Array1d;
begin
slen := length(str);
if slen <= 0 then begin
result := int_Array1d_create(0);
exit;
end;
rlen := 0;
buf := int_Array1d_create(slen);
i := 0;
while i < slen do begin
char1 := int(str[i + 1]);
inc(i);
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 i < slen then begin
char2 := int(str[i + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(i);
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 i < slen then begin
char2 := int(str[i + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(i);
end;
end;
if i < slen then begin
char3 := int(str[i + 1]);
if (char3 and $c0) <> $80 then begin
char3 := 0;
end else begin
inc(i);
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 i < slen then begin
char2 := int(str[i + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(i);
end;
end;
if i < slen then begin
char3 := int(str[i + 1]);
if (char3 and $c0) <> $80 then begin
char3 := 0;
end else begin
inc(i);
end;
end;
if i < slen then begin
char4 := int(str[i + 1]);
if (char4 and $c0) <> $80 then begin
char4 := 0;
end else begin
inc(i);
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 i < slen then begin
char2 := int(str[i + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(i);
end;
end;
if i < slen then begin
char3 := int(str[i + 1]);
if (char3 and $c0) <> $80 then begin
char3 := 0;
end else begin
inc(i);
end;
end;
if i < slen then begin
char4 := int(str[i + 1]);
if (char4 and $c0) <> $80 then begin
char4 := 0;
end else begin
inc(i);
end;
end;
if i < slen then begin
char5 := int(str[i + 1]);
if (char5 and $c0) <> $80 then begin
char5 := 0;
end else begin
inc(i);
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 i < slen then begin
char2 := int(str[i + 1]);
if (char2 and $c0) <> $80 then begin
char2 := 0;
end else begin
inc(i);
end;
end;
if i < slen then begin
char3 := int(str[i + 1]);
if (char3 and $c0) <> $80 then begin
char3 := 0;
end else begin
inc(i);
end;
end;
if i < slen then begin
char4 := int(str[i + 1]);
if (char4 and $c0) <> $80 then begin
char4 := 0;
end else begin
inc(i);
end;
end;
if i < slen then begin
char5 := int(str[i + 1]);
if (char5 and $c0) <> $80 then begin
char5 := 0;
end else begin
inc(i);
end;
end;
if i < slen then begin
char6 := int(str[i + 1]);
if (char6 and $c0) <> $80 then begin
char6 := 0;
end else begin
inc(i);
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;
result := int_Array1d_create(rlen);
arraycopyPrimitives(buf, 0, result, 0, rlen);
end;
function stringToCharCodes(const str: UnicodeString): int_Array1d;
var
i: int;
slen: int;
rlen: int;
code: int;
char1: int;
char2: int;
buf: int_Array1d;
begin
slen := length(str);
if slen <= 0 then begin
result := int_Array1d_create(0);
exit;
end;
rlen := 0;
buf := int_Array1d_create(slen);
i := 0;
while i < slen do begin
char1 := int(str[i + 1]);
inc(i);
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 i < slen then begin
char2 := int(str[i + 1]);
if (char2 < $dc00) or (char2 >= $e000) then begin
char2 := 0;
end else begin
inc(i);
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;
result := int_Array1d_create(rlen);
arraycopyPrimitives(buf, 0, result, 0, rlen);
end;
function stringToCharArray(const str: AnsiString): char_Array1d;
begin
result := char_Array1d_create(length(str));
system.move(str[1], result[0], length(result) * sizeOf(char));
end;
function stringToWCharArray(const str: UnicodeString): wchar_Array1d;
begin
result := wchar_Array1d_create(length(str));
system.move(str[1], result[0], length(result) * sizeOf(wchar));
end;
function stringToByteArray(const str: AnsiString): byte_Array1d;
begin
result := byte_Array1d_create(length(str));
system.move(str[1], result[0], length(result) * sizeOf(byte));
end;
function stringToShortArray(const str: UnicodeString): short_Array1d;
begin
result := short_Array1d_create(length(str));
system.move(str[1], result[0], length(result) * sizeOf(short));
end;
function stringToLowerCase(const str: AnsiString): AnsiString;
label
label0;
var
ci: char;
i: int;
len: int;
buf: char_Array1d;
begin
len := length(str);
i := 0;
begin
while i < len do begin
ci := str[i + 1];
if ci <> charToLowerCase(ci) then goto label0;
inc(i);
end;
result := str;
exit;
end;
label0:
buf := stringToCharArray(str);
while i < len do begin
buf[i] := charToLowerCase(buf[i]);
inc(i);
end;
result := AnsiString_create(buf, 0, len);
end;
function stringToLowerCase(const str: UnicodeString): UnicodeString;
label
label0;
var
ci: wchar;
i: int;
len: int;
buf: wchar_Array1d;
begin
len := length(str);
i := 0;
begin
while i < len do begin
ci := str[i + 1];
if ci <> charToLowerCase(ci) then goto label0;
inc(i);
end;
result := str;
exit;
end;
label0:
buf := stringToWCharArray(str);
while i < len do begin
buf[i] := charToLowerCase(buf[i]);
inc(i);
end;
result := UnicodeString_create(buf, 0, len);
end;
function stringToUpperCase(const str: AnsiString): AnsiString;
label
label0;
var
ci: char;
i: int;
len: int;
buf: char_Array1d;
begin
len := length(str);
i := 0;
begin
while i < len do begin
ci := str[i + 1];
if ci <> charToUpperCase(ci) then goto label0;
inc(i);
end;
result := str;
exit;
end;
label0:
buf := stringToCharArray(str);
while i < len do begin
buf[i] := charToUpperCase(buf[i]);
inc(i);
end;
result := AnsiString_create(buf, 0, len);
end;
function stringToUpperCase(const str: UnicodeString): UnicodeString;
label
label0;
var
ci: wchar;
i: int;
len: int;
buf: wchar_Array1d;
begin
len := length(str);
i := 0;
begin
while i < len do begin
ci := str[i + 1];
if ci <> charToUpperCase(ci) then goto label0;
inc(i);
end;
result := str;
exit;
end;
label0:
buf := stringToWCharArray(str);
while i < len do begin
buf[i] := charToUpperCase(buf[i]);
inc(i);
end;
result := UnicodeString_create(buf, 0, len);
end;
function stringReplace(const str: AnsiString; oldCharacter, newCharacter: char): AnsiString;
var
i: int;
len: int;
buf: char_Array1d;
begin
if oldCharacter = newCharacter then begin
result := str;
exit;
end;
len := length(str);
i := 0;
while (i < len) and (str[i + 1] <> oldCharacter) do begin
inc(i);
end;
if i >= len then begin
result := str;
exit;
end;
buf := stringToCharArray(str);
while i < len do begin
if buf[i] = oldCharacter then buf[i] := newCharacter;
inc(i);
end;
result := AnsiString_create(buf, 0, len);
end;
function stringReplace(const str: UnicodeString; oldCharacter, newCharacter: wchar): UnicodeString;
var
i: int;
len: int;
buf: wchar_Array1d;
begin
if oldCharacter = newCharacter then begin
result := str;
exit;
end;
len := length(str);
i := 0;
while (i < len) and (str[i + 1] <> oldCharacter) do begin
inc(i);
end;
if i >= len then begin
result := str;
exit;
end;
buf := stringToWCharArray(str);
while i < len do begin
if buf[i] = oldCharacter then buf[i] := newCharacter;
inc(i);
end;
result := UnicodeString_create(buf, 0, len);
end;
function stringStartsWith(const prefix, str: AnsiString; position: int): boolean;
var
i: int;
j: int;
len: int;
begin
dec(position);
len := length(prefix);
if (position < 0) or (position > length(str) - len) then begin
result := false;
exit;
end;
i := 0;
j := position;
while i < len do begin
if prefix[i + 1] <> str[j + 1] then begin
result := false;
exit;
end;
inc(i);
inc(j);
end;
result := true;
end;
function stringStartsWith(const prefix, str: UnicodeString; position: int): boolean;
var
i: int;
j: int;
len: int;
begin
dec(position);
len := length(prefix);
if (position < 0) or (position > length(str) - len) then begin
result := false;
exit;
end;
i := 0;
j := position;
while i < len do begin
if prefix[i + 1] <> str[j + 1] then begin
result := false;
exit;
end;
inc(i);
inc(j);
end;
result := true;
end;
function stringEndsWith(const suffix, str: AnsiString): boolean;
begin
result := stringStartsWith(suffix, str, length(str) - length(suffix) + 1);
end;
function stringEndsWith(const suffix, str: UnicodeString): boolean;
begin
result := stringStartsWith(suffix, str, length(str) - length(suffix) + 1);
end;
function stringIndexOf(const prefix, str: AnsiString; startFromIndex: int): int;
label
label0;
var
first: char;
len: int;
lim: int;
i: int;
j: int;
begin
dec(startFromIndex);
len := length(prefix);
lim := length(str) - len;
if startFromIndex < 0 then startFromIndex := 0;
if startFromIndex > lim then begin
result := 0;
exit;
end;
if len <= 0 then begin
result := startFromIndex + 1;
exit;
end;
first := prefix[1];
repeat
if str[startFromIndex + 1] = first then begin
i := 1;
j := startFromIndex + 1;
while i < len do begin
if prefix[i + 1] <> str[j + 1] then goto label0;
inc(i);
inc(j);
end;
result := startFromIndex + 1;
exit;
end;
label0:
inc(startFromIndex);
until startFromIndex > lim;
result := 0;
end;
function stringIndexOf(const prefix, str: UnicodeString; startFromIndex: int): int;
label
label0;
var
first: wchar;
len: int;
lim: int;
i: int;
j: int;
begin
dec(startFromIndex);
len := length(prefix);
lim := length(str) - len;
if startFromIndex < 0 then startFromIndex := 0;
if startFromIndex > lim then begin
result := 0;
exit;
end;
if len <= 0 then begin
result := startFromIndex + 1;
exit;
end;
first := prefix[1];
repeat
if str[startFromIndex + 1] = first then begin
i := 1;
j := startFromIndex + 1;
while i < len do begin
if prefix[i + 1] <> str[j + 1] then goto label0;
inc(i);
inc(j);
end;
result := startFromIndex + 1;
exit;
end;
label0:
inc(startFromIndex);
until startFromIndex > lim;
result := 0;
end;
function stringLastIndexOf(const prefix, str: AnsiString; startFromIndex: int): int;
label
label0;
var
first: char;
len: int;
lim: int;
i: int;
j: int;
begin
dec(startFromIndex);
len := length(prefix);
lim := length(str) - len;
if startFromIndex > lim then startFromIndex := lim;
if startFromIndex < 0 then begin
result := 0;
exit;
end;
if len <= 0 then begin
result := startFromIndex + 1;
exit;
end;
first := prefix[1];
repeat
if str[startFromIndex + 1] = first then begin
i := 1;
j := startFromIndex + 1;
while i < len do begin
if prefix[i + 1] <> str[j + 1] then goto label0;
inc(i);
inc(j);
end;
result := startFromIndex + 1;
exit;
end;
label0:
dec(startFromIndex);
until startFromIndex < 0;
result := 0;
end;
function stringLastIndexOf(const prefix, str: UnicodeString; startFromIndex: int): int;
label
label0;
var
first: wchar;
len: int;
lim: int;
i: int;
j: int;
begin
dec(startFromIndex);
len := length(prefix);
lim := length(str) - len;
if startFromIndex > lim then startFromIndex := lim;
if startFromIndex < 0 then begin
result := 0;
exit;
end;
if len <= 0 then begin
result := startFromIndex + 1;
exit;
end;
first := prefix[1];
repeat
if str[startFromIndex + 1] = first then begin
i := 1;
j := startFromIndex + 1;
while i < len do begin
if prefix[i + 1] <> str[j + 1] then goto label0;
inc(i);
inc(j);
end;
result := startFromIndex + 1;
exit;
end;
label0:
dec(startFromIndex);
until startFromIndex < 0;
result := 0;
end;
function stringTrim(const str: AnsiString): AnsiString;
var
i: int;
j: int;
len: int;
begin
len := length(str);
if len <= 0 then begin
result := '';
exit;
end;
i := 0;
while (i < len) and (str[i + 1] <= #$20) do begin
inc(i);
end;
j := len - 1;
while (j >= i) and (str[j + 1] <= #$20) do begin
dec(j);
end;
if j < i then begin
result := '';
exit;
end;
result := stringCopy(str, i + 1, j + 2);
end;
function stringTrim(const str: UnicodeString): UnicodeString;
var
i: int;
j: int;
len: int;
begin
len := length(str);
if len <= 0 then begin
result := '';
exit;
end;
i := 0;
while (i < len) and (str[i + 1] <= #$0020) do begin
inc(i);
end;
j := len - 1;
while (j >= i) and (str[j + 1] <= #$0020) do begin
dec(j);
end;
if j < i then begin
result := '';
exit;
end;
result := stringCopy(str, i + 1, j + 2);
end;
function stringCopy(const str: AnsiString): AnsiString;
var
len: int;
begin
len := length(str);
result := AnsiString_create(len);
system.move(str[1], result[1], len * sizeOf(char));
end;
function stringCopy(const str: AnsiString; beginIndex: int): AnsiString;
var
len: int;
begin
dec(beginIndex);
len := length(str);
if (beginIndex < 0) or (beginIndex > len) then begin
raise StringIndexOutOfBoundsException.create('stringCopy: ' + msgStringIndexOutOfBounds);
end;
if beginIndex = 0 then begin
result := str;
exit;
end;
if beginIndex = len then begin
result := '';
exit;
end;
dec(len, beginIndex);
result := AnsiString_create(len);
system.move(str[beginIndex + 1], result[1], len * sizeOf(char));
end;
function stringCopy(const str: AnsiString; beginIndex, endIndex: int): AnsiString;
var
len: int;
begin
dec(endIndex);
dec(beginIndex);
len := length(str);
if ((beginIndex or endIndex) < 0) or (beginIndex > len) or (endIndex > len) or (beginIndex > endIndex) then begin
raise StringIndexOutOfBoundsException.create('stringCopy: ' + msgStringIndexOutOfBounds);
end;
if endIndex - beginIndex = len then begin
result := str;
exit;
end;
if beginIndex = endIndex then begin
result := '';
exit;
end;
len := endIndex - beginIndex;
result := AnsiString_create(len);
system.move(str[beginIndex + 1], result[1], len * sizeOf(char));
end;
function stringCopy(const str: UnicodeString): UnicodeString;
var
len: int;
begin
len := length(str);
result := UnicodeString_create(len);
system.move(str[1], result[1], len * sizeOf(wchar));
end;
function stringCopy(const str: UnicodeString; beginIndex: int): UnicodeString;
var
len: int;
begin
dec(beginIndex);
len := length(str);
if (beginIndex < 0) or (beginIndex > len) then begin
raise StringIndexOutOfBoundsException.create('stringCopy: ' + msgStringIndexOutOfBounds);
end;
if beginIndex = 0 then begin
result := str;
exit;
end;
if beginIndex = len then begin
result := '';
exit;
end;
dec(len, beginIndex);
result := UnicodeString_create(len);
system.move(str[beginIndex + 1], result[1], len * sizeOf(wchar));
end;
function stringCopy(const str: UnicodeString; beginIndex, endIndex: int): UnicodeString;
var
len: int;
begin
dec(endIndex);
dec(beginIndex);
len := length(str);
if ((beginIndex or endIndex) < 0) or (beginIndex > len) or (endIndex > len) or (beginIndex > endIndex) then begin
raise StringIndexOutOfBoundsException.create('stringCopy: ' + msgStringIndexOutOfBounds);
end;
if endIndex - beginIndex = len then begin
result := str;
exit;
end;
if beginIndex = endIndex then begin
result := '';
exit;
end;
len := endIndex - beginIndex;
result := UnicodeString_create(len);
system.move(str[beginIndex + 1], result[1], len * sizeOf(wchar));
end;
function stringSplit(const str: AnsiString): AnsiString_Array1d;
var
character: char;
boundsLength: int;
beginIndex: int;
endIndex: int;
thisLength: int;
index: int;
start: int;
length: int;
bounds: long;
thisChars: PChar;
boundsData: long_Array1d;
boundsNew: long_Array1d;
splited: AnsiString_Array1d;
begin
boundsLength := 0;
boundsData := long_Array1d_create(15);
thisLength := system.length(str);
thisChars := PChar(str);
beginIndex := 0;
while beginIndex <= thisLength do begin
character := #0;
endIndex := beginIndex;
while endIndex < thisLength do begin
character := thisChars[endIndex];
if (character = #$0d) or (character = #$0a) then break;
inc(endIndex);
end;
if boundsLength = system.length(boundsData) then begin
boundsNew := long_Array1d_create(int((boundsLength shl 1) + 1));
arraycopyPrimitives(boundsData, 0, boundsNew, 0, boundsLength);
boundsData := boundsNew;
end;
boundsData[boundsLength] := (long(beginIndex) and $00000000ffffffff) + (long(endIndex - beginIndex) shl 32);
inc(boundsLength);
beginIndex := endIndex + 1;
if (character = #$0d) and (beginIndex < thisLength) and (thisChars[beginIndex] = #$0a) then inc(beginIndex);
end;
splited := AnsiString_Array1d_create(boundsLength);
for index := boundsLength - 1 downto 0 do begin
bounds := boundsData[index];
start := int(bounds);
length := int(bounds shr 32);
if length <= 0 then begin
splited[index] := '';
end else begin
splited[index] := stringCopy(str, start + 1, start + length + 1);
end;
end;
result := splited;
end;
function stringSplit(const str: UnicodeString): UnicodeString_Array1d;
var
character: wchar;
boundsLength: int;
beginIndex: int;
endIndex: int;
thisLength: int;
index: int;
start: int;
length: int;
bounds: long;
thisChars: PWideChar;
boundsData: long_Array1d;
boundsNew: long_Array1d;
splited: UnicodeString_Array1d;
begin
boundsLength := 0;
boundsData := long_Array1d_create(15);
thisLength := system.length(str);
thisChars := PWideChar(str);
beginIndex := 0;
while beginIndex <= thisLength do begin
character := #0;
endIndex := beginIndex;
while endIndex < thisLength do begin
character := thisChars[endIndex];
if (character = #$0d) or (character = #$0a) then break;
inc(endIndex);
end;
if boundsLength = system.length(boundsData) then begin
boundsNew := long_Array1d_create(int((boundsLength shl 1) + 1));
arraycopyPrimitives(boundsData, 0, boundsNew, 0, boundsLength);
boundsData := boundsNew;
end;
boundsData[boundsLength] := (long(beginIndex) and $00000000ffffffff) + (long(endIndex - beginIndex) shl 32);
inc(boundsLength);
beginIndex := endIndex + 1;
if (character = #$0d) and (beginIndex < thisLength) and (thisChars[beginIndex] = #$0a) then inc(beginIndex);
end;
splited := UnicodeString_Array1d_create(boundsLength);
for index := boundsLength - 1 downto 0 do begin
bounds := boundsData[index];
start := int(bounds);
length := int(bounds shr 32);
if length <= 0 then begin
splited[index] := '';
end else begin
splited[index] := stringCopy(str, start + 1, start + length + 1);
end;
end;
result := splited;
end;
{$IFDEF WINDOWS}
function systemGetTickCount(): long;
begin
result := long(windows.getTickCount64());
end;
function systemGetCurrentDirectory(): UnicodeString;
var
dir: PWideChar;
begin
dir := getMemory($0400);
try
getCurrentDirectoryW($0200, dir);
result := UnicodeString(dir);
finally
freeMemory(dir);
end;
end;
function systemGetCommandLine(): UnicodeString_Array1d;
var
f: boolean;
i: int;
b: int;
cnt: int;
len: int;
line: UnicodeString;
module: PWideChar;
begin
line := UnicodeString(getCommandLineW());
f := false;
cnt := 0;
len := length(line);
for i := 0 to len - 1 do begin
if line[i + 1] = '"' then begin
f := f = false;
end;
if (f = false) and (i > 0) and (line[i] > #$0020) and (line[i + 1] = #$0020) then begin
inc(cnt);
end;
end;
if (len > 0) and (line[len] > #$0020) then begin
inc(cnt);
end;
result := UnicodeString_Array1d_create(cnt);
f := false;
cnt := 0;
b := 0;
for i := 0 to len - 1 do begin
if (f = false) and (line[i + 1] > #$0020) and ((i > 0) and (line[i] = #$0020) or (i = 0)) then begin
b := i;
end;
if line[i + 1] = '"' then begin
f := f = false;
end;
if (f = false) and (line[i + 1] > #$0020) and ((i < len - 1) and (line[i + 2] = #$0020) or (i = len - 1)) then begin
if line[i + 1] = '"' then begin
result[cnt] := stringCopy(line, b + 2, i + 1);
end else begin
result[cnt] := stringCopy(line, b + 1, i + 2);
end;
inc(cnt);
end;
end;
if cnt > 0 then begin
module := getMemory($0400);
try
getModuleFileNameW(0, module, $0200);
result[0] := UnicodeString(module);
finally
freeMemory(module);
end;
end;
end;
{$ELSE}
function systemGetTickCount(): long;
begin
result := getTickCount64();
end;
function systemGetCurrentDirectory(): UnicodeString;
begin
system.getdir(0, result);
end;
function stringParseCommandLine(): UnicodeString_Array1d;
var
i: int;
cnt: int;
begin
cnt := system.argc;
result := UnicodeString_Array1d_create(cnt);
for i := 0 to cnt - 1 do begin
result[i] := stringToUTF16(AnsiString(argv[i]));
end;
if cnt > 0 then begin
result[0] := stringReplace(result[0], '/', DIRECTORY_SEPARATOR);
end;
end;
{$ENDIF}
function pointerToLongBits(p: Pointer): long; inline;
begin
result := long((@p)^);
end;
function getParentClass(cls: TClass; unamlen, cnamlen: int; const unam, cnam: AnsiString): TClass;
var
currunam: AnsiString;
currcnam: AnsiString;
begin
repeat
currunam := cls.unitName();
currcnam := cls.className();
if (length(currunam) = unamlen) and (length(currcnam) = cnamlen) and (stringToLowerCase(currunam) = unam) and (stringToLowerCase(currcnam) = cnam) then begin
result := cls;
exit;
end;
cls := cls.classParent();
until cls = nil;
result := nil;
end;
function getParentInterface(info: PTypeInfo; data: PTypeData; unamlen, cnamlen: int; const unam, cnam: AnsiString): PTypeInfo; overload;
var
currunam: AnsiString;
currcnam: AnsiString;
begin
repeat
currcnam := info^.name;
currunam := data^.intfUnit;
if (length(currunam) = unamlen) and (length(currcnam) = cnamlen) and (stringToLowerCase(currunam) = unam) and (stringToLowerCase(currcnam) = cnam) then begin
result := info;
exit;
end;
info := data^.intfParent;
if info = nil then break;
data := getTypeData(info);
until false;
result := nil;
end;
function getParentInterface(info: PTypeInfo; const iid: TGuid): PTypeInfo; overload;
var
data: PTypeData;
begin
repeat
data := getTypeData(info);
if isEqualGuid(data^.iid, iid) then begin
result := info;
exit;
end;
info := data^.intfParent;
until info = nil;
result := nil;
end;
function getParentType(typ: _Class; unamlen, cnamlen: int; const unam, cnam: AnsiString): _Class;
var
currunam: AnsiString;
currcnam: AnsiString;
begin
repeat
currunam := typ.getUnitName();
currcnam := typ.getSimpleName();
if (length(currunam) = unamlen) and (length(currcnam) = cnamlen) and (stringToLowerCase(currunam) = unam) and (stringToLowerCase(currcnam) = cnam) then begin
result := typ;
exit;
end;
typ := typ.getSuperclass();
until typ = nil;
result := nil;
end;
function classForType(const info: TGuid): _Class;
var
i: int;
tinfo: PTypeInfo;
begin
for i := typeInfosLength - 1 downto 0 do begin
tinfo := typeInfosData[i];
if tinfo = nil then continue;
case tinfo^.kind of
tkInterface, tkInterfaceRaw: begin
tinfo := getParentInterface(tinfo, info);
if tinfo <> nil then begin
result := InterfaceInformation.create(tinfo);
exit;
end;
end;
end;
end;
result := GuidInformation.create(info);
end;
function classForType(const info: TClass): _Class;
begin
result := ClassInformation.create(info);
end;
function classForType(const info: Pointer): _Class;
var
tinfo: PTypeInfo absolute info;
tkind: int;
begin
tkind := int(tinfo^.kind);
case tkind of
int(TTypeKind.tkClass):
result := ClassInformation.create(getTypeData(tinfo)^.classType);
int(TTypeKind.tkInterface), int(TTypeKind.tkInterfaceRaw):
result := InterfaceInformation.create(tinfo);
else
if (tkind < 0) or (tkind >= 30) then begin
raise IllegalArgumentException.create('classForType: ' + msgIllegalArgument + 'info');
end;
result := PrimitiveInformation.create(ClassInformation.typeInfoToLangType(tinfo), tinfo^.name);
end;
end;
function classForName(const name: AnsiString): _Class;
var
iid: TGuid;
pos: int;
unam: AnsiString;
cnam: AnsiString;
unamlen: int;
cnamlen: int;
found: PTypeInfo;
i: int;
info: PTypeInfo;
data: PTypeData;
kind: TTypeKind;
parentClass: TClass;
parentInterface: PTypeInfo;
currunam: AnsiString;
unitenum: TypeEnumeration;
currtype: _Class;
begin
if tryStringToGUID(name, iid) then begin
result := classForType(iid);
exit;
end;
pos := stringLastIndexOf('.', name);
if pos <= 0 then begin
unam := stringToLowerCase(name);
unamlen := length(unam);
for i := 0 to length(primitivesData) - 1 do begin
currtype := primitivesData[i];
currunam := currtype.getCanonicalName();
if (length(currunam) = unamlen) and (stringToLowerCase(currunam) = unam) then begin
result := currtype;
exit;
end;
end;
result := nil;
exit;
end;
unam := stringToLowerCase(stringCopy(name, 1, pos));
cnam := stringToLowerCase(stringCopy(name, pos + 1));
unamlen := length(unam);
cnamlen := length(cnam);
found := nil;
for i := 0 to typeInfosLength - 1 do begin
info := typeInfosData[i];
if info = nil then continue;
data := getTypeData(info);
kind := info^.kind;
case kind of
tkClass: begin
parentClass := getParentClass(data^.classType, unamlen, cnamlen, unam, cnam);
if parentClass <> nil then begin
result := ClassInformation.create(parentClass);
exit;
end;
currunam := data^.unitName;
end;
tkInterface, tkInterfaceRaw: begin
parentInterface := getParentInterface(info, data, unamlen, cnamlen, unam, cnam);
if parentInterface <> nil then begin
result := InterfaceInformation.create(parentInterface);
exit;
end;
currunam := data^.intfUnit;
end
else
continue;
end;
if (length(currunam) = unamlen) and (stringToLowerCase(currunam) = unam) and ((found = nil) or (long((@info)^) < long((@found)^))) then begin
{ указатели в длинном режиме — целые числа со знаком! }
found := info;
end;
end;
if found <> nil then begin
unitenum := TypeEnumeration.create(found);
try
while unitenum.hasMoreElements() do begin
currtype := getParentType(unitenum.nextElement(), unamlen, cnamlen, unam, cnam);
if currtype <> nil then begin
result := currtype;
exit;
end;
end;
finally
unitenum.free();
end;
end;
result := nil;
end;
function nextAlignedAfter(address: Pointer): Pointer; assembler; nostackframe;
asm
mov rax, rcx
neg rax
and rax, $07
lea rax, [rcx+rax]
end;
function AnsiString_create(length: int): AnsiString;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function AnsiString_create(const src: byte_Array1d; offset, length: int): AnsiString;
begin
arrayCheckBounds('', system.length(src), offset, length);
result := AnsiString_create(length);
system.move(src[offset], result[1], length * sizeOf(char));
end;
function AnsiString_create(const src: char_Array1d; offset, length: int): AnsiString;
begin
arrayCheckBounds('', system.length(src), offset, length);
result := AnsiString_create(length);
system.move(src[offset], result[1], length * sizeOf(char));
end;
function UnicodeString_create(length: int): UnicodeString;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function UnicodeString_create(const src: short_Array1d; offset, length: int): UnicodeString;
begin
arrayCheckBounds('', system.length(src), offset, length);
result := UnicodeString_create(length);
system.move(src[offset], result[1], length * sizeOf(wchar));
end;
function UnicodeString_create(const src: wchar_Array1d; offset, length: int): UnicodeString;
begin
arrayCheckBounds('', system.length(src), offset, length);
result := UnicodeString_create(length);
system.move(src[offset], result[1], length * sizeOf(wchar));
end;
function boolean_Array1d_create(length: int): boolean_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function boolean_Array1d_create(const elements: array of boolean): boolean_Array1d;
begin
system.setLength(result, length(elements));
system.move(elements[0], result[0], length(result) * sizeOf(boolean));
end;
function char_Array1d_create(length: int): char_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function char_Array1d_create(const elements: array of char): char_Array1d;
begin
system.setLength(result, length(elements));
system.move(elements[0], result[0], length(result) * sizeOf(char));
end;
function wchar_Array1d_create(length: int): wchar_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function wchar_Array1d_create(const elements: array of wchar): wchar_Array1d;
begin
system.setLength(result, length(elements));
system.move(elements[0], result[0], length(result) * sizeOf(wchar));
end;
function byte_Array1d_create(length: int): byte_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function byte_Array1d_create(const elements: array of byte): byte_Array1d;
begin
system.setLength(result, length(elements));
system.move(elements[0], result[0], length(result) * sizeOf(byte));
end;
function short_Array1d_create(length: int): short_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function short_Array1d_create(const elements: array of short): short_Array1d;
begin
system.setLength(result, length(elements));
system.move(elements[0], result[0], length(result) * sizeOf(short));
end;
function int_Array1d_create(length: int): int_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function int_Array1d_create(const elements: array of int): int_Array1d;
begin
system.setLength(result, length(elements));
system.move(elements[0], result[0], length(result) * sizeOf(int));
end;
function long_Array1d_create(length: int): long_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function long_Array1d_create(const elements: array of long): long_Array1d;
begin
system.setLength(result, length(elements));
system.move(elements[0], result[0], length(result) * sizeOf(long));
end;
function float_Array1d_create(length: int): float_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function float_Array1d_create(const elements: array of float): float_Array1d;
begin
system.setLength(result, length(elements));
system.move(elements[0], result[0], length(result) * sizeOf(float));
end;
function double_Array1d_create(length: int): double_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function double_Array1d_create(const elements: array of double): double_Array1d;
begin
system.setLength(result, length(elements));
system.move(elements[0], result[0], length(result) * sizeOf(double));
end;
function real_Array1d_create(length: int): real_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function real_Array1d_create(const elements: array of real): real_Array1d;
begin
system.setLength(result, length(elements));
system.move(elements[0], result[0], length(result) * sizeOf(real));
end;
function TObject_Array1d_create(length: int): TObject_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function TObject_Array1d_create(const elements: array of TObject): TObject_Array1d;
begin
system.setLength(result, length(elements));
system.move(elements[0], result[0], length(result) * sizeOf(TObject));
end;
function IUnknown_Array1d_create(length: int): IUnknown_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function IUnknown_Array1d_create(const elements: array of IUnknown): IUnknown_Array1d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function AnsiString_Array1d_create(length: int): AnsiString_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function AnsiString_Array1d_create(const elements: array of AnsiString): AnsiString_Array1d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function UnicodeString_Array1d_create(length: int): UnicodeString_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function UnicodeString_Array1d_create(const elements: array of UnicodeString): UnicodeString_Array1d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function Pointer_Array1d_create(length: int): Pointer_Array1d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function boolean_Array2d_create(length: int): boolean_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function boolean_Array2d_create(length1, length2: int): boolean_Array2d;
var
i: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length1);
for i := length1 - 1 downto 0 do begin
system.setLength(result[i], length2);
end;
end;
function boolean_Array2d_create(const elements: array of boolean_Array1d): boolean_Array2d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function char_Array2d_create(length: int): char_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function char_Array2d_create(length1, length2: int): char_Array2d;
var
i: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length1);
for i := length1 - 1 downto 0 do begin
system.setLength(result[i], length2);
end;
end;
function char_Array2d_create(const elements: array of char_Array1d): char_Array2d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function wchar_Array2d_create(length: int): wchar_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function wchar_Array2d_create(length1, length2: int): wchar_Array2d;
var
i: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length1);
for i := length1 - 1 downto 0 do begin
system.setLength(result[i], length2);
end;
end;
function wchar_Array2d_create(const elements: array of wchar_Array1d): wchar_Array2d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function byte_Array2d_create(length: int): byte_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function byte_Array2d_create(length1, length2: int): byte_Array2d;
var
i: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length1);
for i := length1 - 1 downto 0 do begin
system.setLength(result[i], length2);
end;
end;
function byte_Array2d_create(const elements: array of byte_Array1d): byte_Array2d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function short_Array2d_create(length: int): short_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function short_Array2d_create(length1, length2: int): short_Array2d;
var
i: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length1);
for i := length1 - 1 downto 0 do begin
system.setLength(result[i], length2);
end;
end;
function short_Array2d_create(const elements: array of short_Array1d): short_Array2d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function int_Array2d_create(length: int): int_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function int_Array2d_create(length1, length2: int): int_Array2d;
var
i: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length1);
for i := length1 - 1 downto 0 do begin
system.setLength(result[i], length2);
end;
end;
function int_Array2d_create(const elements: array of int_Array1d): int_Array2d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function long_Array2d_create(length: int): long_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function long_Array2d_create(length1, length2: int): long_Array2d;
var
i: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length1);
for i := length1 - 1 downto 0 do begin
system.setLength(result[i], length2);
end;
end;
function long_Array2d_create(const elements: array of long_Array1d): long_Array2d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function float_Array2d_create(length: int): float_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function float_Array2d_create(length1, length2: int): float_Array2d;
var
i: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length1);
for i := length1 - 1 downto 0 do begin
system.setLength(result[i], length2);
end;
end;
function float_Array2d_create(const elements: array of float_Array1d): float_Array2d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function double_Array2d_create(length: int): double_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function double_Array2d_create(length1, length2: int): double_Array2d;
var
i: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length1);
for i := length1 - 1 downto 0 do begin
system.setLength(result[i], length2);
end;
end;
function double_Array2d_create(const elements: array of double_Array1d): double_Array2d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function real_Array2d_create(length: int): real_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function real_Array2d_create(length1, length2: int): real_Array2d;
var
i: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length1);
for i := length1 - 1 downto 0 do begin
system.setLength(result[i], length2);
end;
end;
function real_Array2d_create(const elements: array of real_Array1d): real_Array2d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function TObject_Array2d_create(length: int): TObject_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function TObject_Array2d_create(length1, length2: int): TObject_Array2d;
var
i: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length1);
for i := length1 - 1 downto 0 do begin
system.setLength(result[i], length2);
end;
end;
function TObject_Array2d_create(const elements: array of TObject_Array1d): TObject_Array2d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function IUnknown_Array2d_create(length: int): IUnknown_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function IUnknown_Array2d_create(length1, length2: int): IUnknown_Array2d;
var
i: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length1);
for i := length1 - 1 downto 0 do begin
system.setLength(result[i], length2);
end;
end;
function IUnknown_Array2d_create(const elements: array of IUnknown_Array1d): IUnknown_Array2d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function AnsiString_Array2d_create(length: int): AnsiString_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function AnsiString_Array2d_create(length1, length2: int): AnsiString_Array2d;
var
i: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length1);
for i := length1 - 1 downto 0 do begin
system.setLength(result[i], length2);
end;
end;
function AnsiString_Array2d_create(const elements: array of AnsiString_Array1d): AnsiString_Array2d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function UnicodeString_Array2d_create(length: int): UnicodeString_Array2d;
begin
if length < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length);
end;
function UnicodeString_Array2d_create(length1, length2: int): UnicodeString_Array2d;
var
i: int;
begin
if (length1 or length2) < 0 then begin
raise NegativeArraySizeException.create(msgNegativeArraySize);
end;
system.setLength(result, length1);
for i := length1 - 1 downto 0 do begin
system.setLength(result[i], length2);
end;
end;
function UnicodeString_Array2d_create(const elements: array of UnicodeString_Array1d): UnicodeString_Array2d;
var
i: int;
begin
system.setLength(result, length(elements));
for i := length(result) - 1 downto 0 do begin
result[i] := elements[i];
end;
end;
function arrayequalsf(src, dst: Pointer; size, length: int): int; assembler; nostackframe;
asm
push rsi
push rdi
lea r10, [rip+@1-@0]
@0: movsxd r11, [r10+r8*8+$04] { r8=size }
lea r10, [r10+r11]
jmp r10
align $04
@1: xchg eax, eax
lea r10, [r10+@size0-@1]
xchg eax, eax
lea r10, [r10+@size1-@1]
xchg eax, eax
lea r10, [r10+@size2-@1]
xchg eax, eax
lea r10, [r10+@size3-@1]
@size0: mov rsi, rcx { src }
mov rdi, rdx { dst }
movsxd rcx, r9d { length }
mov r10, rdi
cld
repe cmpsb
je @nf
sub rdi, r10
sar rdi, $00
jmp @exit
align $04
@size1: mov rsi, rcx { src }
mov rdi, rdx { dst }
movsxd rcx, r9d { length }
mov r10, rdi
cld
repe cmpsw
je @nf
sub rdi, r10
sar rdi, $01
jmp @exit
align $04
@size2: mov rsi, rcx { src }
mov rdi, rdx { dst }
movsxd rcx, r9d { length }
mov r10, rdi
cld
repe cmpsd
je @nf
sub rdi, r10
sar rdi, $02
jmp @exit
align $04
@size3: mov rsi, rcx { src }
mov rdi, rdx { dst }
movsxd rcx, r9d { length }
mov r10, rdi
cld
repe cmpsq
je @nf
sub rdi, r10
sar rdi, $03
jmp @exit
align $04
@nf: mov eax, -$01
pop rdi
pop rsi
ret
@exit: lea eax, [edi-$01]
pop rdi
pop rsi
end;
function arrayequalsfPrimitive(const src: boolean_Array1d; srcOffset: int; const dst: boolean_Array1d; dstOffset: int; length: int): int; overload;
begin
arrayCheckBounds('arrayequalsfPrimitive', system.length(src), srcOffset, length);
arrayCheckBounds('arrayequalsfPrimitive', system.length(dst), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsf(@(src[srcOffset]), @(dst[dstOffset]), 0, length);
end;
function arrayequalsfPrimitive(const src: char_Array1d; srcOffset: int; const dst: char_Array1d; dstOffset: int; length: int): int; overload;
begin
arrayCheckBounds('arrayequalsfPrimitive', system.length(src), srcOffset, length);
arrayCheckBounds('arrayequalsfPrimitive', system.length(dst), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsf(@(src[srcOffset]), @(dst[dstOffset]), 0, length);
end;
function arrayequalsfPrimitive(const src: wchar_Array1d; srcOffset: int; const dst: wchar_Array1d; dstOffset: int; length: int): int; overload;
begin
arrayCheckBounds('arrayequalsfPrimitive', system.length(src), srcOffset, length);
arrayCheckBounds('arrayequalsfPrimitive', system.length(dst), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsf(@(src[srcOffset]), @(dst[dstOffset]), 1, length);
end;
function arrayequalsfPrimitive(const src: byte_Array1d; srcOffset: int; const dst: byte_Array1d; dstOffset: int; length: int): int;
begin
arrayCheckBounds('arrayequalsfPrimitive', system.length(src), srcOffset, length);
arrayCheckBounds('arrayequalsfPrimitive', system.length(dst), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsf(@(src[srcOffset]), @(dst[dstOffset]), 0, length);
end;
function arrayequalsfPrimitive(const src: short_Array1d; srcOffset: int; const dst: short_Array1d; dstOffset: int; length: int): int; overload;
begin
arrayCheckBounds('arrayequalsfPrimitive', system.length(src), srcOffset, length);
arrayCheckBounds('arrayequalsfPrimitive', system.length(dst), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsf(@(src[srcOffset]), @(dst[dstOffset]), 1, length);
end;
function arrayequalsfPrimitive(const src: int_Array1d; srcOffset: int; const dst: int_Array1d; dstOffset: int; length: int): int; overload;
begin
arrayCheckBounds('arrayequalsfPrimitive', system.length(src), srcOffset, length);
arrayCheckBounds('arrayequalsfPrimitive', system.length(dst), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsf(@(src[srcOffset]), @(dst[dstOffset]), 2, length);
end;
function arrayequalsfPrimitive(const src: long_Array1d; srcOffset: int; const dst: long_Array1d; dstOffset: int; length: int): int; overload;
begin
arrayCheckBounds('arrayequalsfPrimitive', system.length(src), srcOffset, length);
arrayCheckBounds('arrayequalsfPrimitive', system.length(dst), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsf(@(src[srcOffset]), @(dst[dstOffset]), 3, length);
end;
function arrayequalsfInterface(const src; srcOffset: int; const dst; dstOffset: int; length: int): int;
begin
arrayCheckBounds('arrayequalsfInterface', system.length(Pointer_Array1d(src)), srcOffset, length);
arrayCheckBounds('arrayequalsfInterface', system.length(Pointer_Array1d(dst)), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsf(@(Pointer_Array1d(src)[srcOffset]), @(Pointer_Array1d(dst)[dstOffset]), 3, length);
end;
function arrayequalsfObject(const src; srcOffset: int; const dst; dstOffset: int; length: int): int;
begin
arrayCheckBounds('arrayequalsfObject', system.length(Pointer_Array1d(src)), srcOffset, length);
arrayCheckBounds('arrayequalsfObject', system.length(Pointer_Array1d(dst)), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsf(@(Pointer_Array1d(src)[srcOffset]), @(Pointer_Array1d(dst)[dstOffset]), 3, length);
end;
function arrayequalsfArray(const src; srcOffset: int; const dst; dstOffset: int; length: int): int;
begin
arrayCheckBounds('arrayequalsfArray', system.length(Pointer_Array1d(src)), srcOffset, length);
arrayCheckBounds('arrayequalsfArray', system.length(Pointer_Array1d(dst)), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsf(@(Pointer_Array1d(src)[srcOffset]), @(Pointer_Array1d(dst)[dstOffset]), 3, length);
end;
function arrayequalsb(src, dst: Pointer; size, length: int): int; assembler; nostackframe;
asm
push rsi
push rdi
lea r10, [rip+@1-@0]
@0: movsxd r11, [r10+r8*8+$04] { r8=size }
lea r10, [r10+r11]
jmp r10
align $04
@1: xchg eax, eax
lea r10, [r10+@size0-@1]
xchg eax, eax
lea r10, [r10+@size1-@1]
xchg eax, eax
lea r10, [r10+@size2-@1]
xchg eax, eax
lea r10, [r10+@size3-@1]
@size0: mov rsi, rcx { src }
mov rdi, rdx { dst }
movsxd rcx, r9d { length }
mov r10, rdi
std
repe cmpsb
je @nf
sub rdi, r10
sar rdi, $00
jmp @exit
align $04
@size1: mov rsi, rcx { src }
mov rdi, rdx { dst }
movsxd rcx, r9d { length }
mov r10, rdi
std
repe cmpsw
je @nf
sub rdi, r10
sar rdi, $01
jmp @exit
align $04
@size2: mov rsi, rcx { src }
mov rdi, rdx { dst }
movsxd rcx, r9d { length }
mov r10, rdi
std
repe cmpsd
je @nf
sub rdi, r10
sar rdi, $02
jmp @exit
align $04
@size3: mov rsi, rcx { src }
mov rdi, rdx { dst }
movsxd rcx, r9d { length }
mov r10, rdi
std
repe cmpsq
je @nf
sub rdi, r10
sar rdi, $03
jmp @exit
align $04
@nf: mov eax, -$01
pop rdi
pop rsi
cld { сбрасываем флаг направления, дабы избежать потенциальных проблем с системными библиотеками }
ret
@exit: lea eax, [edi+r9d]
pop rdi
pop rsi
cld { сбрасываем флаг направления, дабы избежать потенциальных проблем с системными библиотеками }
end;
function arrayequalsbPrimitive(const src: boolean_Array1d; srcOffset: int; const dst: boolean_Array1d; dstOffset: int; length: int): int; overload;
begin
arrayCheckBounds('arrayequalsbPrimitive', system.length(src), srcOffset, length);
arrayCheckBounds('arrayequalsbPrimitive', system.length(dst), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsb(@(src[srcOffset + length - 1]), @(dst[dstOffset + length - 1]), 0, length);
end;
function arrayequalsbPrimitive(const src: char_Array1d; srcOffset: int; const dst: char_Array1d; dstOffset: int; length: int): int; overload;
begin
arrayCheckBounds('arrayequalsbPrimitive', system.length(src), srcOffset, length);
arrayCheckBounds('arrayequalsbPrimitive', system.length(dst), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsb(@(src[srcOffset + length - 1]), @(dst[dstOffset + length - 1]), 0, length);
end;
function arrayequalsbPrimitive(const src: wchar_Array1d; srcOffset: int; const dst: wchar_Array1d; dstOffset: int; length: int): int; overload;
begin
arrayCheckBounds('arrayequalsbPrimitive', system.length(src), srcOffset, length);
arrayCheckBounds('arrayequalsbPrimitive', system.length(dst), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsb(@(src[srcOffset + length - 1]), @(dst[dstOffset + length - 1]), 1, length);
end;
function arrayequalsbPrimitive(const src: byte_Array1d; srcOffset: int; const dst: byte_Array1d; dstOffset: int; length: int): int;
begin
arrayCheckBounds('arrayequalsbPrimitive', system.length(src), srcOffset, length);
arrayCheckBounds('arrayequalsbPrimitive', system.length(dst), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsb(@(src[srcOffset + length - 1]), @(dst[dstOffset + length - 1]), 0, length);
end;
function arrayequalsbPrimitive(const src: short_Array1d; srcOffset: int; const dst: short_Array1d; dstOffset: int; length: int): int; overload;
begin
arrayCheckBounds('arrayequalsbPrimitive', system.length(src), srcOffset, length);
arrayCheckBounds('arrayequalsbPrimitive', system.length(dst), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsb(@(src[srcOffset + length - 1]), @(dst[dstOffset + length - 1]), 1, length);
end;
function arrayequalsbPrimitive(const src: int_Array1d; srcOffset: int; const dst: int_Array1d; dstOffset: int; length: int): int; overload;
begin
arrayCheckBounds('arrayequalsbPrimitive', system.length(src), srcOffset, length);
arrayCheckBounds('arrayequalsbPrimitive', system.length(dst), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsb(@(src[srcOffset + length - 1]), @(dst[dstOffset + length - 1]), 2, length);
end;
function arrayequalsbPrimitive(const src: long_Array1d; srcOffset: int; const dst: long_Array1d; dstOffset: int; length: int): int; overload;
begin
arrayCheckBounds('arrayequalsbPrimitive', system.length(src), srcOffset, length);
arrayCheckBounds('arrayequalsbPrimitive', system.length(dst), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsb(@(src[srcOffset + length - 1]), @(dst[dstOffset + length - 1]), 3, length);
end;
function arrayequalsbInterface(const src; srcOffset: int; const dst; dstOffset: int; length: int): int;
begin
arrayCheckBounds('arrayequalsbInterface', system.length(Pointer_Array1d(src)), srcOffset, length);
arrayCheckBounds('arrayequalsbInterface', system.length(Pointer_Array1d(dst)), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsb(@(Pointer_Array1d(src)[srcOffset + length - 1]), @(Pointer_Array1d(dst)[dstOffset + length - 1]), 3, length);
end;
function arrayequalsbObject(const src; srcOffset: int; const dst; dstOffset: int; length: int): int;
begin
arrayCheckBounds('arrayequalsbObject', system.length(Pointer_Array1d(src)), srcOffset, length);
arrayCheckBounds('arrayequalsbObject', system.length(Pointer_Array1d(dst)), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsb(@(Pointer_Array1d(src)[srcOffset + length - 1]), @(Pointer_Array1d(dst)[dstOffset + length - 1]), 3, length);
end;
function arrayequalsbArray(const src; srcOffset: int; const dst; dstOffset: int; length: int): int;
begin
arrayCheckBounds('arrayequalsbArray', system.length(Pointer_Array1d(src)), srcOffset, length);
arrayCheckBounds('arrayequalsbArray', system.length(Pointer_Array1d(dst)), dstOffset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayequalsb(@(Pointer_Array1d(src)[srcOffset + length - 1]), @(Pointer_Array1d(dst)[dstOffset + length - 1]), 3, length);
end;
function arrayfindeqf(src: Pointer; size, length: int; value: long): int; assembler; nostackframe;
asm
push rdi
lea r10, [rip+@1-@0]
@0: movsxd r11, [r10+rdx*8+$04] { rdx=size }
lea r10, [r10+r11]
jmp r10
align $04
@1: xchg eax, eax
lea r10, [r10+@size0-@1]
xchg eax, eax
lea r10, [r10+@size1-@1]
xchg eax, eax
lea r10, [r10+@size2-@1]
xchg eax, eax
lea r10, [r10+@size3-@1]
@size0: mov rdi, rcx { src }
movzx rax, r9b { value }
movsxd rcx, r8d { length }
mov r10, rdi
cld
repne scasb
jne @nf
sub rdi, r10
sar rdi, $00
jmp @exit
align $04
@size1: mov rdi, rcx { src }
movzx rax, r9w { value }
movsxd rcx, r8d { length }
mov r10, rdi
cld
repne scasw
jne @nf
sub rdi, r10
sar rdi, $01
jmp @exit
align $04
@size2: mov rdi, rcx { src }
mov eax, r9d { value }
movsxd rcx, r8d { length }
mov r10, rdi
cld
repne scasd
jne @nf
sub rdi, r10
sar rdi, $02
jmp @exit
align $04
@size3: mov rdi, rcx { src }
mov rax, r9 { value }
movsxd rcx, r8d { length }
mov r10, rdi
cld
repne scasq
jne @nf
sub rdi, r10
sar rdi, $03
jmp @exit
align $04
@nf: mov eax, -$01
pop rdi
ret
@exit: lea eax, [edi-$01]
pop rdi
end;
function arrayfindeqfPrimitive(const src: boolean_Array1d; offset, length: int; value: boolean): int;
var
val: int;
begin
arrayCheckBounds('arrayfindeqfPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
if value then begin
val := 1;
end else begin
val := 0;
end;
result := arrayfindeqf(@(src[offset]), 0, length, val);
end;
function arrayfindeqfPrimitive(const src: char_Array1d; offset, length: int; value: char): int;
begin
arrayCheckBounds('arrayfindeqfPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqf(@(src[offset]), 0, length, long(value));
end;
function arrayfindeqfPrimitive(const src: wchar_Array1d; offset, length: int; value: wchar): int;
begin
arrayCheckBounds('arrayfindeqfPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqf(@(src[offset]), 1, length, long(value));
end;
function arrayfindeqfPrimitive(const src: byte_Array1d; offset, length: int; value: int): int;
begin
arrayCheckBounds('arrayfindeqfPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqf(@(src[offset]), 0, length, value);
end;
function arrayfindeqfPrimitive(const src: short_Array1d; offset, length: int; value: int): int;
begin
arrayCheckBounds('arrayfindeqfPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqf(@(src[offset]), 1, length, value);
end;
function arrayfindeqfPrimitive(const src: int_Array1d; offset, length: int; value: int): int;
begin
arrayCheckBounds('arrayfindeqfPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqf(@(src[offset]), 2, length, value);
end;
function arrayfindeqfPrimitive(const src: long_Array1d; offset, length: int; value: long): int;
begin
arrayCheckBounds('arrayfindeqfPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqf(@(src[offset]), 3, length, value);
end;
function arrayfindeqfInterface(const src; offset, length: int; value: IUnknown): int;
begin
arrayCheckBounds('arrayfindeqfInterface', system.length(Pointer_Array1d(src)), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqf(@(Pointer_Array1d(src)[offset]), 3, length, long(value));
end;
function arrayfindeqfObject(const src; offset, length: int; value: TObject): int;
begin
arrayCheckBounds('arrayfindeqfObject', system.length(Pointer_Array1d(src)), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqf(@(Pointer_Array1d(src)[offset]), 3, length, long(value));
end;
function arrayfindeqfArray(const src; offset, length: int; const value): int;
begin
arrayCheckBounds('arrayfindeqfArray', system.length(Pointer_Array1d(src)), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqf(@(Pointer_Array1d(src)[offset]), 3, length, long(value));
end;
function arrayfindeqb(src: Pointer; size, length: int; value: long): int; assembler; nostackframe;
asm
push rdi
lea r10, [rip+@1-@0]
@0: movsxd r11, [r10+rdx*8+$04] { rdx=size }
lea r10, [r10+r11]
jmp r10
align $04
@1: xchg eax, eax
lea r10, [r10+@size0-@1]
xchg eax, eax
lea r10, [r10+@size1-@1]
xchg eax, eax
lea r10, [r10+@size2-@1]
xchg eax, eax
lea r10, [r10+@size3-@1]
@size0: mov rdi, rcx { src }
movzx rax, r9b { value }
movsxd rcx, r8d { length }
mov r10, rdi
std
repne scasb
jne @nf
sub rdi, r10
sar rdi, $00
jmp @exit
align $04
@size1: mov rdi, rcx { src }
movzx rax, r9w { value }
movsxd rcx, r8d { length }
mov r10, rdi
std
repne scasw
jne @nf
sub rdi, r10
sar rdi, $01
jmp @exit
align $04
@size2: mov rdi, rcx { src }
mov eax, r9d { value }
movsxd rcx, r8d { length }
mov r10, rdi
std
repne scasd
jne @nf
sub rdi, r10
sar rdi, $02
jmp @exit
align $04
@size3: mov rdi, rcx { src }
mov rax, r9 { value }
movsxd rcx, r8d { length }
mov r10, rdi
std
repne scasq
jne @nf
sub rdi, r10
sar rdi, $03
jmp @exit
align $04
@nf: mov eax, -$01
pop rdi
cld { сбрасываем флаг направления, дабы избежать потенциальных проблем с системными библиотеками }
ret
@exit: lea eax, [edi+r8d]
pop rdi
cld { сбрасываем флаг направления, дабы избежать потенциальных проблем с системными библиотеками }
end;
function arrayfindeqbPrimitive(const src: boolean_Array1d; offset, length: int; value: boolean): int;
var
val: int;
begin
arrayCheckBounds('arrayfindeqbPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
if value then begin
val := 1;
end else begin
val := 0;
end;
result := arrayfindeqb(@(src[offset + length - 1]), 0, length, val);
end;
function arrayfindeqbPrimitive(const src: char_Array1d; offset, length: int; value: char): int;
begin
arrayCheckBounds('arrayfindeqbPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqb(@(src[offset + length - 1]), 0, length, long(value));
end;
function arrayfindeqbPrimitive(const src: wchar_Array1d; offset, length: int; value: wchar): int;
begin
arrayCheckBounds('arrayfindeqbPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqb(@(src[offset + length - 1]), 1, length, long(value));
end;
function arrayfindeqbPrimitive(const src: byte_Array1d; offset, length: int; value: int): int;
begin
arrayCheckBounds('arrayfindeqbPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqb(@(src[offset + length - 1]), 0, length, value);
end;
function arrayfindeqbPrimitive(const src: short_Array1d; offset, length: int; value: int): int;
begin
arrayCheckBounds('arrayfindeqbPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqb(@(src[offset + length - 1]), 1, length, value);
end;
function arrayfindeqbPrimitive(const src: int_Array1d; offset, length: int; value: int): int;
begin
arrayCheckBounds('arrayfindeqbPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqb(@(src[offset + length - 1]), 2, length, value);
end;
function arrayfindeqbPrimitive(const src: long_Array1d; offset, length: int; value: long): int;
begin
arrayCheckBounds('arrayfindeqbPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqb(@(src[offset + length - 1]), 3, length, value);
end;
function arrayfindeqbInterface(const src; offset, length: int; value: IUnknown): int;
begin
arrayCheckBounds('arrayfindeqbInterface', system.length(Pointer_Array1d(src)), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqb(@(Pointer_Array1d(src)[offset + length - 1]), 3, length, long(value));
end;
function arrayfindeqbObject(const src; offset, length: int; value: TObject): int;
begin
arrayCheckBounds('arrayfindeqbObject', system.length(Pointer_Array1d(src)), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqb(@(Pointer_Array1d(src)[offset + length - 1]), 3, length, long(value));
end;
function arrayfindeqbArray(const src; offset, length: int; const value): int;
begin
arrayCheckBounds('arrayfindeqbArray', system.length(Pointer_Array1d(src)), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindeqb(@(Pointer_Array1d(src)[offset + length - 1]), 3, length, long(value));
end;
function arrayfindnef(src: Pointer; size, length: int; value: long): int; assembler; nostackframe;
asm
push rdi
lea r10, [rip+@1-@0]
@0: movsxd r11, [r10+rdx*8+$04] { rdx=size }
lea r10, [r10+r11]
jmp r10
align $04
@1: xchg eax, eax
lea r10, [r10+@size0-@1]
xchg eax, eax
lea r10, [r10+@size1-@1]
xchg eax, eax
lea r10, [r10+@size2-@1]
xchg eax, eax
lea r10, [r10+@size3-@1]
@size0: mov rdi, rcx { src }
movzx rax, r9b { value }
movsxd rcx, r8d { length }
mov r10, rdi
cld
repe scasb
je @nf
sub rdi, r10
sar rdi, $00
jmp @exit
align $04
@size1: mov rdi, rcx { src }
movzx rax, r9w { value }
movsxd rcx, r8d { length }
mov r10, rdi
cld
repe scasw
je @nf
sub rdi, r10
sar rdi, $01
jmp @exit
align $04
@size2: mov rdi, rcx { src }
mov eax, r9d { value }
movsxd rcx, r8d { length }
mov r10, rdi
cld
repe scasd
je @nf
sub rdi, r10
sar rdi, $02
jmp @exit
align $04
@size3: mov rdi, rcx { src }
mov rax, r9 { value }
movsxd rcx, r8d { length }
mov r10, rdi
cld
repe scasq
je @nf
sub rdi, r10
sar rdi, $03
jmp @exit
align $04
@nf: mov eax, -$01
pop rdi
ret
@exit: lea eax, [edi-$01]
pop rdi
end;
function arrayfindnefPrimitive(const src: boolean_Array1d; offset, length: int; value: boolean): int;
var
val: int;
begin
arrayCheckBounds('arrayfindnefPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
if value then begin
val := 1;
end else begin
val := 0;
end;
result := arrayfindnef(@(src[offset]), 0, length, val);
end;
function arrayfindnefPrimitive(const src: char_Array1d; offset, length: int; value: char): int;
begin
arrayCheckBounds('arrayfindnefPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindnef(@(src[offset]), 0, length, long(value));
end;
function arrayfindnefPrimitive(const src: wchar_Array1d; offset, length: int; value: wchar): int;
begin
arrayCheckBounds('arrayfindnefPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindnef(@(src[offset]), 1, length, long(value));
end;
function arrayfindnefPrimitive(const src: byte_Array1d; offset, length: int; value: int): int;
begin
arrayCheckBounds('arrayfindnefPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindnef(@(src[offset]), 0, length, value);
end;
function arrayfindnefPrimitive(const src: short_Array1d; offset, length: int; value: int): int;
begin
arrayCheckBounds('arrayfindnefPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindnef(@(src[offset]), 1, length, value);
end;
function arrayfindnefPrimitive(const src: int_Array1d; offset, length: int; value: int): int;
begin
arrayCheckBounds('arrayfindnefPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindnef(@(src[offset]), 2, length, value);
end;
function arrayfindnefPrimitive(const src: long_Array1d; offset, length: int; value: long): int;
begin
arrayCheckBounds('arrayfindnefPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindnef(@(src[offset]), 3, length, value);
end;
function arrayfindnefInterface(const src; offset, length: int; value: IUnknown): int;
begin
arrayCheckBounds('arrayfindnefInterface', system.length(Pointer_Array1d(src)), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindnef(@(Pointer_Array1d(src)[offset]), 3, length, long(value));
end;
function arrayfindnefObject(const src; offset, length: int; value: TObject): int;
begin
arrayCheckBounds('arrayfindnefObject', system.length(Pointer_Array1d(src)), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindnef(@(Pointer_Array1d(src)[offset]), 3, length, long(value));
end;
function arrayfindnefArray(const src; offset, length: int; const value): int;
begin
arrayCheckBounds('arrayfindnefArray', system.length(Pointer_Array1d(src)), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindnef(@(Pointer_Array1d(src)[offset]), 3, length, long(value));
end;
function arrayfindneb(src: Pointer; size, length: int; value: long): int; assembler; nostackframe;
asm
push rdi
lea r10, [rip+@1-@0]
@0: movsxd r11, [r10+rdx*8+$04] { rdx=size }
lea r10, [r10+r11]
jmp r10
align $04
@1: xchg eax, eax
lea r10, [r10+@size0-@1]
xchg eax, eax
lea r10, [r10+@size1-@1]
xchg eax, eax
lea r10, [r10+@size2-@1]
xchg eax, eax
lea r10, [r10+@size3-@1]
@size0: mov rdi, rcx { src }
movzx rax, r9b { value }
movsxd rcx, r8d { length }
mov r10, rdi
std
repe scasb
je @nf
sub rdi, r10
sar rdi, $00
jmp @exit
align $04
@size1: mov rdi, rcx { src }
movzx rax, r9w { value }
movsxd rcx, r8d { length }
mov r10, rdi
std
repe scasw
je @nf
sub rdi, r10
sar rdi, $01
jmp @exit
align $04
@size2: mov rdi, rcx { src }
mov eax, r9d { value }
movsxd rcx, r8d { length }
mov r10, rdi
std
repe scasd
je @nf
sub rdi, r10
sar rdi, $02
jmp @exit
align $04
@size3: mov rdi, rcx { src }
mov rax, r9 { value }
movsxd rcx, r8d { length }
mov r10, rdi
std
repe scasq
je @nf
sub rdi, r10
sar rdi, $03
jmp @exit
align $04
@nf: mov eax, -$01
pop rdi
cld { сбрасываем флаг направления, дабы избежать потенциальных проблем с системными библиотеками }
ret
@exit: lea eax, [edi+r8d]
pop rdi
cld { сбрасываем флаг направления, дабы избежать потенциальных проблем с системными библиотеками }
end;
function arrayfindnebPrimitive(const src: boolean_Array1d; offset, length: int; value: boolean): int;
var
val: int;
begin
arrayCheckBounds('arrayfindnebPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
if value then begin
val := 1;
end else begin
val := 0;
end;
result := arrayfindneb(@(src[offset + length - 1]), 0, length, val);
end;
function arrayfindnebPrimitive(const src: char_Array1d; offset, length: int; value: char): int;
begin
arrayCheckBounds('arrayfindnebPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindneb(@(src[offset + length - 1]), 0, length, long(value));
end;
function arrayfindnebPrimitive(const src: wchar_Array1d; offset, length: int; value: wchar): int;
begin
arrayCheckBounds('arrayfindnebPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindneb(@(src[offset + length - 1]), 1, length, long(value));
end;
function arrayfindnebPrimitive(const src: byte_Array1d; offset, length: int; value: int): int;
begin
arrayCheckBounds('arrayfindnebPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindneb(@(src[offset + length - 1]), 0, length, value);
end;
function arrayfindnebPrimitive(const src: short_Array1d; offset, length: int; value: int): int;
begin
arrayCheckBounds('arrayfindnebPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindneb(@(src[offset + length - 1]), 1, length, value);
end;
function arrayfindnebPrimitive(const src: int_Array1d; offset, length: int; value: int): int;
begin
arrayCheckBounds('arrayfindnebPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindneb(@(src[offset + length - 1]), 2, length, value);
end;
function arrayfindnebPrimitive(const src: long_Array1d; offset, length: int; value: long): int;
begin
arrayCheckBounds('arrayfindnebPrimitive', system.length(src), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindneb(@(src[offset + length - 1]), 3, length, value);
end;
function arrayfindnebInterface(const src; offset, length: int; value: IUnknown): int;
begin
arrayCheckBounds('arrayfindnebInterface', system.length(Pointer_Array1d(src)), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindneb(@(Pointer_Array1d(src)[offset + length - 1]), 3, length, long(value));
end;
function arrayfindnebObject(const src; offset, length: int; value: TObject): int;
begin
arrayCheckBounds('arrayfindnebObject', system.length(Pointer_Array1d(src)), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindneb(@(Pointer_Array1d(src)[offset + length - 1]), 3, length, long(value));
end;
function arrayfindnebArray(const src; offset, length: int; const value): int;
begin
arrayCheckBounds('arrayfindnebArray', system.length(Pointer_Array1d(src)), offset, length);
if length <= 0 then begin
result := -1;
exit;
end;
result := arrayfindneb(@(Pointer_Array1d(src)[offset + length - 1]), 3, length, long(value));
end;
procedure arrayfill(dst: Pointer; size, length: int; value: long); assembler; nostackframe;
asm
push rdi
lea rdi, [rip+@1-@0]
@0: movsxd rdx, [rdi+rdx*8+$04] { rdx=size }
lea rdx, [rdi+rdx]
jmp rdx
align $04
@1: xchg eax, eax
lea r10, [r10+@size0-@1]
xchg eax, eax
lea r10, [r10+@size1-@1]
xchg eax, eax
lea r10, [r10+@size2-@1]
xchg eax, eax
lea r10, [r10+@size3-@1]
@size0: mov rdi, rcx { dst }
movzx rax, r9b { value }
movsxd rcx, r8d { length }
cld
rep stosb
jmp @exit
align $04
@size1: mov rdi, rcx { dst }
movzx rax, r9w { value }
movsxd rcx, r8d { length }
cld
rep stosw
jmp @exit
align $04
@size2: mov rdi, rcx { dst }
mov eax, r9d { value }
movsxd rcx, r8d { length }
cld
rep stosd
jmp @exit
align $04
@size3: mov rdi, rcx { dst }
mov rax, r9 { value }
movsxd rcx, r8d { length }
cld
rep stosq
@exit: pop rdi
end;
procedure arrayfillPrimitives(const dst: boolean_Array1d; offset, length: int; value: boolean);
var
len: int;
val: int;
begin
len := system.length(dst);
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
if length > 0 then begin
if value then begin
val := 1;
end else begin
val := 0;
end;
arrayfill(@(dst[offset]), 0, length, val);
end;
end;
procedure arrayfillPrimitives(const dst: char_Array1d; offset, length: int; value: char);
var
len: int;
begin
len := system.length(dst);
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
if length > 0 then begin
arrayfill(@(dst[offset]), 0, length, int(value));
end;
end;
procedure arrayfillPrimitives(const dst: wchar_Array1d; offset, length: int; value: wchar);
var
len: int;
begin
len := system.length(dst);
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
if length > 0 then begin
arrayfill(@(dst[offset]), 1, length, int(value));
end;
end;
procedure arrayfillPrimitives(const dst: byte_Array1d; offset, length: int; value: int);
var
len: int;
begin
len := system.length(dst);
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
if length > 0 then begin
arrayfill(@(dst[offset]), 0, length, value);
end;
end;
procedure arrayfillPrimitives(const dst: short_Array1d; offset, length: int; value: int);
var
len: int;
begin
len := system.length(dst);
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
if length > 0 then begin
arrayfill(@(dst[offset]), 1, length, value);
end;
end;
procedure arrayfillPrimitives(const dst: int_Array1d; offset, length: int; value: int);
var
len: int;
begin
len := system.length(dst);
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
if length > 0 then begin
arrayfill(@(dst[offset]), 2, length, value);
end;
end;
procedure arrayfillPrimitives(const dst: long_Array1d; offset, length: int; value: long);
var
len: int;
begin
len := system.length(dst);
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
if length > 0 then begin
arrayfill(@(dst[offset]), 3, length, value);
end;
end;
procedure arrayfillPrimitives(const dst: float_Array1d; offset, length: int; value: float);
var
len: int;
begin
len := system.length(dst);
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
if length > 0 then begin
arrayfill(@(dst[offset]), 2, length, floatToIntBits(value));
end;
end;
procedure arrayfillPrimitives(const dst: double_Array1d; offset, length: int; value: double);
var
len: int;
begin
len := system.length(dst);
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
if length > 0 then begin
arrayfill(@(dst[offset]), 3, length, doubleToLongBits(value));
end;
end;
procedure arrayfillPrimitives(const dst: real_Array1d; offset, length: int; const value: real);
var
i: int;
len: int;
begin
len := system.length(dst);
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
for i := offset to offset + length - 1 do begin
dst[i] := value;
end;
end;
procedure arrayfillAnsiStrings(const dst: AnsiString_Array1d; offset, length: int; const value: AnsiString);
var
i: int;
len: int;
begin
len := system.length(dst);
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
for i := offset to offset + length - 1 do begin
dst[i] := value;
end;
end;
procedure arrayfillUnicodeStrings(const dst: UnicodeString_Array1d; offset, length: int; const value: UnicodeString);
var
i: int;
len: int;
begin
len := system.length(dst);
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
for i := offset to offset + length - 1 do begin
dst[i] := value;
end;
end;
procedure arrayfillInterfaces(const dst; offset, length: int; value: IUnknown);
var
i: int;
len: int;
begin
len := system.length(IUnknown_Array1d(dst));
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
for i := offset to offset + length - 1 do begin
IUnknown_Array1d(dst)[i] := value;
end;
end;
procedure arrayfillObjects(const dst; offset, length: int; value: TObject);
var
len: int;
begin
len := system.length(TObject_Array1d(dst));
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
if length > 0 then begin
arrayfill(@(TObject_Array1d(dst)[offset]), 3, length, long(value));
end;
end;
procedure arrayfillArrays(const dst; offset, length: int; const value);
var
i: int;
len: int;
begin
len := system.length(boolean_Array2d(dst));
if offset < 0 then begin
inc(length, offset);
offset := 0;
end;
if offset + length > len then begin
length := len - offset;
end;
for i := offset to offset + length - 1 do begin
boolean_Array2d(dst)[i] := boolean_Array1d(value);
end;
end;
procedure arraycopyPrimitives(const src: boolean_Array1d; srcOffset: int; const dst: boolean_Array1d; dstOffset: int; length: int);
begin
arrayCheckBounds('arraycopyPrimitives', system.length(src), srcOffset, length);
arrayCheckBounds('arraycopyPrimitives', system.length(dst), dstOffset, length);
system.move(src[srcOffset], dst[dstOffset], length * sizeOf(boolean));
end;
procedure arraycopyPrimitives(const src: char_Array1d; srcOffset: int; const dst: char_Array1d; dstOffset: int; length: int);
begin
arrayCheckBounds('arraycopyPrimitives', system.length(src), srcOffset, length);
arrayCheckBounds('arraycopyPrimitives', system.length(dst), dstOffset, length);
system.move(src[srcOffset], dst[dstOffset], length * sizeOf(char));
end;
procedure arraycopyPrimitives(const src: wchar_Array1d; srcOffset: int; const dst: wchar_Array1d; dstOffset: int; length: int);
begin
arrayCheckBounds('arraycopyPrimitives', system.length(src), srcOffset, length);
arrayCheckBounds('arraycopyPrimitives', system.length(dst), dstOffset, length);
system.move(src[srcOffset], dst[dstOffset], length * sizeOf(wchar));
end;
procedure arraycopyPrimitives(const src: byte_Array1d; srcOffset: int; const dst: byte_Array1d; dstOffset: int; length: int);
begin
arrayCheckBounds('arraycopyPrimitives', system.length(src), srcOffset, length);
arrayCheckBounds('arraycopyPrimitives', system.length(dst), dstOffset, length);
system.move(src[srcOffset], dst[dstOffset], length * sizeOf(byte));
end;
procedure arraycopyPrimitives(const src: short_Array1d; srcOffset: int; const dst: short_Array1d; dstOffset: int; length: int);
begin
arrayCheckBounds('arraycopyPrimitives', system.length(src), srcOffset, length);
arrayCheckBounds('arraycopyPrimitives', system.length(dst), dstOffset, length);
system.move(src[srcOffset], dst[dstOffset], length * sizeOf(short));
end;
procedure arraycopyPrimitives(const src: int_Array1d; srcOffset: int; const dst: int_Array1d; dstOffset: int; length: int);
begin
arrayCheckBounds('arraycopyPrimitives', system.length(src), srcOffset, length);
arrayCheckBounds('arraycopyPrimitives', system.length(dst), dstOffset, length);
system.move(src[srcOffset], dst[dstOffset], length * sizeOf(int));
end;
procedure arraycopyPrimitives(const src: long_Array1d; srcOffset: int; const dst: long_Array1d; dstOffset: int; length: int);
begin
arrayCheckBounds('arraycopyPrimitives', system.length(src), srcOffset, length);
arrayCheckBounds('arraycopyPrimitives', system.length(dst), dstOffset, length);
system.move(src[srcOffset], dst[dstOffset], length * sizeOf(long));
end;
procedure arraycopyPrimitives(const src: float_Array1d; srcOffset: int; const dst: float_Array1d; dstOffset: int; length: int);
begin
arrayCheckBounds('arraycopyPrimitives', system.length(src), srcOffset, length);
arrayCheckBounds('arraycopyPrimitives', system.length(dst), dstOffset, length);
system.move(src[srcOffset], dst[dstOffset], length * sizeOf(float));
end;
procedure arraycopyPrimitives(const src: double_Array1d; srcOffset: int; const dst: double_Array1d; dstOffset: int; length: int);
begin
arrayCheckBounds('arraycopyPrimitives', system.length(src), srcOffset, length);
arrayCheckBounds('arraycopyPrimitives', system.length(dst), dstOffset, length);
system.move(src[srcOffset], dst[dstOffset], length * sizeOf(double));
end;
procedure arraycopyPrimitives(const src: real_Array1d; srcOffset: int; const dst: real_Array1d; dstOffset: int; length: int);
begin
arrayCheckBounds('arraycopyPrimitives', system.length(src), srcOffset, length);
arrayCheckBounds('arraycopyPrimitives', system.length(dst), dstOffset, length);
system.move(src[srcOffset], dst[dstOffset], length * sizeOf(real));
end;
procedure arraycopyAnsiStrings(const src: AnsiString_Array1d; srcOffset: int; const dst: AnsiString_Array1d; dstOffset: int; length: int);
var
i: int;
begin
arrayCheckBounds('arraycopyAnsiStrings', system.length(src), srcOffset, length);
arrayCheckBounds('arraycopyAnsiStrings', system.length(dst), dstOffset, length);
if (src = dst) and (srcOffset < dstOffset) then begin
inc(srcOffset, length);
inc(dstOffset, length);
for i := length - 1 downto 0 do begin
dec(srcOffset);
dec(dstOffset);
dst[dstOffset] := src[srcOffset];
end;
end else begin
for i := 0 to length - 1 do begin
dst[dstOffset] := src[srcOffset];
inc(srcOffset);
inc(dstOffset);
end;
end;
end;
procedure arraycopyUnicodeStrings(const src: UnicodeString_Array1d; srcOffset: int; const dst: UnicodeString_Array1d; dstOffset: int; length: int);
var
i: int;
begin
arrayCheckBounds('arraycopyUnicodeStrings', system.length(src), srcOffset, length);
arrayCheckBounds('arraycopyUnicodeStrings', system.length(dst), dstOffset, length);
if (src = dst) and (srcOffset < dstOffset) then begin
inc(srcOffset, length);
inc(dstOffset, length);
for i := length - 1 downto 0 do begin
dec(srcOffset);
dec(dstOffset);
dst[dstOffset] := src[srcOffset];
end;
end else begin
for i := 0 to length - 1 do begin
dst[dstOffset] := src[srcOffset];
inc(srcOffset);
inc(dstOffset);
end;
end;
end;
procedure arraycopyInterfaces(const src; srcOffset: int; const dst; dstOffset: int; length: int);
var
i: int;
begin
arrayCheckBounds('arraycopyInterfaces', system.length(IUnknown_Array1d(src)), srcOffset, length);
arrayCheckBounds('arraycopyInterfaces', system.length(IUnknown_Array1d(dst)), dstOffset, length);
if (IUnknown_Array1d(src) = IUnknown_Array1d(dst)) and (srcOffset < dstOffset) then begin
inc(srcOffset, length);
inc(dstOffset, length);
for i := length - 1 downto 0 do begin
dec(srcOffset);
dec(dstOffset);
IUnknown_Array1d(dst)[dstOffset] := IUnknown_Array1d(src)[srcOffset];
end;
end else begin
for i := 0 to length - 1 do begin
IUnknown_Array1d(dst)[dstOffset] := IUnknown_Array1d(src)[srcOffset];
inc(srcOffset);
inc(dstOffset);
end;
end;
end;
procedure arraycopyObjects(const src; srcOffset: int; const dst; dstOffset: int; length: int);
begin
arrayCheckBounds('arraycopyObjects', system.length(TObject_Array1d(src)), srcOffset, length);
arrayCheckBounds('arraycopyObjects', system.length(TObject_Array1d(dst)), dstOffset, length);
system.move(TObject_Array1d(src)[srcOffset], TObject_Array1d(dst)[dstOffset], length * sizeOf(TObject));
end;
procedure arraycopyArrays(const src; srcOffset: int; const dst; dstOffset: int; length: int);
var
i: int;
begin
arrayCheckBounds('arraycopyArrays', system.length(boolean_Array2d(src)), srcOffset, length);
arrayCheckBounds('arraycopyArrays', system.length(boolean_Array2d(dst)), dstOffset, length);
if (boolean_Array2d(src) = boolean_Array2d(dst)) and (srcOffset < dstOffset) then begin
inc(srcOffset, length);
inc(dstOffset, length);
for i := length - 1 downto 0 do begin
dec(srcOffset);
dec(dstOffset);
boolean_Array2d(dst)[dstOffset] := boolean_Array2d(src)[srcOffset];
end;
end else begin
for i := 0 to length - 1 do begin
boolean_Array2d(dst)[dstOffset] := boolean_Array2d(src)[srcOffset];
inc(srcOffset);
inc(dstOffset);
end;
end;
end;
procedure arraycopyPointers(const src; srcOffset: int; const dst; dstOffset: int; length: int);
begin
arrayCheckBounds('arraycopyPointers', system.length(Pointer_Array1d(src)), srcOffset, length);
arrayCheckBounds('arraycopyPointers', system.length(Pointer_Array1d(dst)), dstOffset, length);
system.move(Pointer_Array1d(src)[srcOffset], Pointer_Array1d(dst)[dstOffset], length * sizeOf(Pointer));
end;
procedure arrayCheckBounds(const method: AnsiString; arrayLength, offset, length: int);
var
lim: int;
begin
lim := offset + length;
if (lim > arrayLength) or (lim < offset) or (offset > arrayLength) or (offset < 0) then begin
if system.length(method) <= 0 then begin
raise ArrayIndexOutOfBoundsException.create(msgArrayIndexOutOfBounds);
end;
raise ArrayIndexOutOfBoundsException.create(method + ': ' + msgArrayIndexOutOfBounds);
end;
end;
procedure synchronized(m: Monitor);
var
needRaise: boolean;
needSuspend: boolean;
lOwningEntry: Monitor.ThreadEntry;
currentThread: TThread;
begin
if m = nil then begin
raise NullPointerException.create(msgNullPointer);
end;
needRaise := false;
needSuspend := false;
system.enterCriticalSection(m.fMonitorSynchronize);
try
lOwningEntry := m.fOwningEntry;
currentThread := Thread.currentThread;
if lOwningEntry = nil then begin
if m.fWaitingCount >= INT_MAX_VALUE then begin
needRaise := true;
end else begin
m.fOwningEntry := Monitor.ThreadEntry.create(m, currentThread, RUNNING);
end;
end else
if lOwningEntry.fMonitorThread = currentThread then begin
inc(lOwningEntry.fEntryCount);
end else begin
if m.fWaitingCount >= INT_MAX_VALUE - 1 then begin
needRaise := true;
end else begin
needSuspend := true;
lOwningEntry := Monitor.ThreadEntry.create(m, currentThread, SUSPENDED);
m.push(lOwningEntry);
end;
end;
finally
system.leaveCriticalSection(m.fMonitorSynchronize);
end;
if needRaise then begin
raise IllegalMonitorStateException.create(msgIllegalMonitorState);
end;
if needSuspend then begin
lOwningEntry.suspend();
end;
end;
procedure synchronizedEnd(m: Monitor);
var
needRaise: boolean;
lEntryCount: long;
lOwningEntry: Monitor.ThreadEntry;
begin
if m = nil then begin
raise NullPointerException.create(msgNullPointer);
end;
needRaise := false;
system.enterCriticalSection(m.fMonitorSynchronize);
try
lOwningEntry := m.fOwningEntry;
if (lOwningEntry = nil) or (lOwningEntry.fMonitorThread <> Thread.currentThread) then begin
needRaise := true;
end else begin
lEntryCount := lOwningEntry.fEntryCount - 1;
lOwningEntry.fEntryCount := lEntryCount;
if lEntryCount = 0 then begin
lOwningEntry.free();
m.fOwningEntry := nil;
m.pop();
end;
end;
finally
system.leaveCriticalSection(m.fMonitorSynchronize);
end;
if needRaise then begin
raise IllegalMonitorStateException.create(msgIllegalMonitorState);
end;
end;
procedure classInfoAdd(const typeInfos: array of Pointer);
var
curlen: int;
curcap: int;
addlen: int;
newlen: int;
newcap: int;
newdata: PTypeInfo_Array1d;
begin
curlen := typeInfosLength;
curcap := length(typeInfosData);
addlen := length(typeInfos);
newlen := curlen + addlen;
if newlen > curcap then begin
newcap := (curcap shl 1) + 1;
if newcap < newlen then newcap := newlen;
newdata := PTypeInfo_Array1d(Pointer_Array1d_create(newcap));
system.move(typeInfosData[0], newdata[0], curlen * sizeOf(PTypeInfo));
typeInfosData := newdata;
end;
system.move(typeInfos[0], typeInfosData[curlen], addlen * sizeOf(PTypeInfo));
typeInfosLength := newlen;
end;
{$IFDEF WINDOWS}
function getExceptionObject(errorNumber: int; const rec: Windows.TExceptionRecord): TObject;
var
e: TObject;
begin
e := nil;
case errorNumber of
1,
203: e := outOfMemory;
204: e := invalidPointer;
200,
205,
206,
207,
215: e := ArithmeticException.create(msgArithmeticError);
202: e := StackOverflowError.create(msgStackOverflow);
211: e := AbstractMethodError.create(msgAbstractMethod);
216: e := NullPointerException.create(msgNullPointer);
219: e := ClassCastException.create(msgClassCast);
else e := previousGetExceptionObject(errorNumber, rec);
end;
if e = nil then begin
e := NullPointerException.create(msgNullPointer);
end;
result := e;
end;
function getExceptionClass(errorNumber: int): TClass;
var
c: TClass;
begin
c := nil;
case errorNumber of
1,
203: c := OutOfMemoryError;
204: c := InvalidPointerError;
200,
205,
206,
207,
215: c := ArithmeticException;
202: c := StackOverflowError;
211: c := AbstractMethodError;
216: c := NullPointerException;
219: c := ClassCastException;
else c := previousGetExceptionClass(errorNumber);
end;
if c = nil then begin
c := NullPointerException;
end;
result := c;
end;
{$ENDIF}
procedure exceptionHandler(errorNumber: int; address: CodePointer; frame: Pointer);
var
e: TObject;
begin
e := nil;
case errorNumber of
1,
203: e := outOfMemory;
204: e := invalidPointer;
200,
205,
206,
207,
215: e := ArithmeticException.create(msgArithmeticError);
202: e := StackOverflowError.create(msgStackOverflow);
211: e := AbstractMethodError.create(msgAbstractMethod);
216: e := NullPointerException.create(msgNullPointer);
219: e := ClassCastException.create(msgClassCast);
else previousExceptionHandler(errorNumber, address, frame);
end;
if e = nil then begin
e := NullPointerException.create(msgNullPointer);
end;
raise e at address, frame;
end;
procedure exceptionHandlerInitialize();
begin
{$IFDEF WINDOWS}
previousGetExceptionObject := FunctionGetExceptionObject(exceptObjProc);
previousGetExceptionClass := FunctionGetExceptionClass(exceptClsProc);
{$ENDIF}
previousExceptionHandler := errorProc;
outOfMemory := OutOfMemoryError.create(msgOutOfMemory);
outOfMemory.disallowFree := true;
invalidPointer := InvalidPointerError.create(msgInvalidPointer);
invalidPointer.disallowFree := true;
{$IFDEF WINDOWS}
exceptObjProc := @getExceptionObject;
exceptClsProc := @getExceptionClass;
{$ENDIF}
errorProc := @exceptionHandler;
end;
procedure exceptionHandlerFinalize();
begin
{$IFDEF WINDOWS}
exceptObjProc := previousGetExceptionObject;
exceptClsProc := previousGetExceptionClass;
{$ENDIF}
errorProc := previousExceptionHandler;
invalidPointer.disallowFree := false;
invalidPointer.free();
outOfMemory.disallowFree := false;
outOfMemory.free();
end;
{%endregion}
{%region operator }
operator :=(value: byte): real; assembler; nostackframe;
asm
movsx edx, dl
push rdx
fild dword[rsp]
fstp tbyte[rcx]
lea rsp, [rsp+$08]
end;
operator :=(value: short): real; assembler; nostackframe;
asm
movsx edx, dx
push rdx
fild dword[rsp]
fstp tbyte[rcx]
lea rsp, [rsp+$08]
end;
operator :=(value: int): real; assembler; nostackframe;
asm
push rdx
fild dword[rsp]
fstp tbyte[rcx]
lea rsp, [rsp+$08]
end;
operator :=(value: long): real; assembler; nostackframe;
asm
push rdx
fild qword[rsp]
fstp tbyte[rcx]
lea rsp, [rsp+$08]
end;
operator :=(value: float): real; assembler; nostackframe;
asm
lea rsp, [rsp-$08]
movss [rsp], xmm1
fld dword[rsp]
fstp tbyte[rcx]
lea rsp, [rsp+$08]
end;
operator :=(value: double): real; assembler; nostackframe;
asm
lea rsp, [rsp-$08]
movsd [rsp], xmm1
fld qword[rsp]
fstp tbyte[rcx]
lea rsp, [rsp+$08]
end;
operator =(const value1, value2: real): boolean; assembler; nostackframe;
asm
fld tbyte[rdx]
fld tbyte[rcx]
fcomip st, st(1)
ffree st
fincstp
jnp @0
mov al, $ff
or eax, eax
stc
@0: sete al
movzx eax, al
end;
operator <(const value1, value2: real): boolean; assembler; nostackframe;
asm
fld tbyte[rdx]
fld tbyte[rcx]
fcomip st, st(1)
ffree st
fincstp
jnp @0
mov al, $ff
or eax, eax
@0: setb al
movzx eax, al
end;
operator >(const value1, value2: real): boolean; assembler; nostackframe;
asm
fld tbyte[rdx]
fld tbyte[rcx]
fcomip st, st(1)
ffree st
fincstp
jnp @0
mov al, $ff
or eax, eax
stc
@0: seta al
movzx eax, al
end;
operator <=(const value1, value2: real): boolean; assembler; nostackframe;
asm
fld tbyte[rdx]
fld tbyte[rcx]
fcomip st, st(1)
ffree st
fincstp
jnp @0
mov al, $ff
or eax, eax
@0: setbe al
movzx eax, al
end;
operator >=(const value1, value2: real): boolean; assembler; nostackframe;
asm
fld tbyte[rdx]
fld tbyte[rcx]
fcomip st, st(1)
ffree st
fincstp
jnp @0
mov al, $ff
or eax, eax
stc
@0: setae al
movzx eax, al
end;
operator <>(const value1, value2: real): boolean; assembler; nostackframe;
asm
fld tbyte[rdx]
fld tbyte[rcx]
fcomip st, st(1)
ffree st
fincstp
jnp @0
mov al, $ff
or eax, eax
stc
@0: setne al
movzx eax, al
end;
operator +(const value1, value2: real): real; assembler; nostackframe;
asm
fld tbyte[rdx]
fld tbyte[r8]
faddp st(1), st
fstp tbyte[rcx]
end;
operator -(const value1, value2: real): real; assembler; nostackframe;
asm
fld tbyte[rdx]
fld tbyte[r8]
fsubp st(1), st
fstp tbyte[rcx]
end;
operator *(const value1, value2: real): real; assembler; nostackframe;
asm
fld tbyte[rdx]
fld tbyte[r8]
fmulp st(1), st
fstp tbyte[rcx]
end;
operator /(const value1, value2: real): real; assembler; nostackframe;
asm
fld tbyte[rdx]
fld tbyte[r8]
fdivp st(1), st
fstp tbyte[rcx]
end;
operator +(const value: real): real; assembler; nostackframe;
asm
fld tbyte[rdx]
fstp tbyte[rcx]
end;
operator -(const value: real): real; assembler; nostackframe;
asm
fld tbyte[rdx]
fchs
fstp tbyte[rcx]
end;
{%endregion}
{%region TObjectExtended }
class function TObjectExtended.getPropertyInfo(const name: AnsiString): PPropInfo;
var
i: int;
count: int;
lnlen: int;
pinfo: PPropInfo;
tinfo: PTypeInfo;
tdata: PTypeData;
lname: AnsiString;
pname: AnsiString;
begin
lname := stringToLowerCase(name);
lnlen := length(lname);
tinfo := PTypeInfo(self.classInfo());
while tinfo <> nil do begin
tdata := getTypeData(tinfo);
pinfo := PPropInfo(Pointer(@(tdata^.unitName[1])) + int(tdata^.unitName[0]));
count := system.PUInt16(pinfo)^;
pinfo := Pointer(pinfo) + 2;
for i := 0 to count - 1 do begin
pname := pinfo^.name;
if (length(pname) = lnlen) and (stringToLowerCase(pname) = lname) then begin
result := pinfo;
exit;
end;
pinfo := PPropInfo(Pointer(@(pinfo^.name[1])) + int(pinfo^.name[0]));
end;
tinfo := tdata^.parentInfo;
end;
result := nil;
end;
function TObjectExtended.getClass(): _Class;
begin
result := ClassInformation.create(classType());
end;
function TObjectExtended.getIdentityHashCode(): long;
begin
result := long(self);
end;
function TObjectExtended.isStoredProperty(const name: AnsiString): boolean;
type
FunctionIsStoredIndex = function(index: int): boolean of object;
FunctionIsStoredNorm = function(): boolean of object;
var
isIndexed: boolean;
transferMethod: int;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.isStoredProperty: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := (transferMethod shr 4) and $03;
case transferMethod of
TM_FIELD: begin
access := pinfo^.storedProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.isStoredProperty: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
address := Pointer(self) + long((@access)^);
end;
TM_CONST:
address := @(pinfo^.storedProc);
else
access := pinfo^.storedProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.isStoredProperty: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
result := FunctionIsStoredIndex(method)(pinfo^.index);
exit;
end;
result := FunctionIsStoredNorm(method)();
exit;
end;
result := byte(address^) <> 0;
end;
function TObjectExtended.readPropertyOfBoolean(const name: AnsiString): boolean;
type
FunctionReadBooleanIndex = function(index: int): boolean of object;
FunctionReadBooleanNorm = function(): boolean of object;
var
isIndexed: boolean;
transferMethod: int;
propertyType: int;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.readPropertyOfBoolean: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
propertyType := ClassInformation.typeInfoToLangType(pinfo^.propType);
case propertyType of
TYPE_BOOLEAN: begin
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := transferMethod and $03;
case transferMethod of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.readPropertyOfBoolean: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
address := Pointer(self) + long((@access)^);
end;
TM_CONST:
address := @(pinfo^.getProc);
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.readPropertyOfBoolean: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
result := FunctionReadBooleanIndex(method)(pinfo^.index);
exit;
end;
result := FunctionReadBooleanNorm(method)();
exit;
end;
result := byte(address^) <> 0;
end
else
raise IllegalPropertyTypeException.create('TObjectExtended.readPropertyOfBoolean: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
end;
function TObjectExtended.readPropertyOfLong(const name: AnsiString): long;
type
FunctionReadUByteIndex = function(index: int): system.UInt8 of object;
FunctionReadUShortIndex = function(index: int): system.UInt16 of object;
FunctionReadUIntIndex = function(index: int): system.UInt32 of object;
FunctionReadByteIndex = function(index: int): byte of object;
FunctionReadShortIndex = function(index: int): short of object;
FunctionReadIntIndex = function(index: int): int of object;
FunctionReadLongIndex = function(index: int): long of object;
FunctionReadUByteNorm = function(): system.UInt8 of object;
FunctionReadUShortNorm = function(): system.UInt16 of object;
FunctionReadUIntNorm = function(): system.UInt32 of object;
FunctionReadByteNorm = function(): byte of object;
FunctionReadShortNorm = function(): short of object;
FunctionReadIntNorm = function(): int of object;
FunctionReadLongNorm = function(): long of object;
var
isIndexed: boolean;
transferMethod: int;
propertyType: int;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.readPropertyOfLong: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
propertyType := ClassInformation.typeInfoToLangType(pinfo^.propType);
case propertyType of
TYPE_CHAR, TYPE_WCHAR, TYPE_BYTE, TYPE_SHORT, TYPE_INT, TYPE_LONG, TYPE_UBYTE, TYPE_USHORT, TYPE_UINT, TYPE_ULONG: begin
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := transferMethod and $03;
case transferMethod of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.readPropertyOfLong: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
address := Pointer(self) + long((@access)^);
end;
TM_CONST:
address := @(pinfo^.getProc);
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.readPropertyOfLong: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
case propertyType of
TYPE_UBYTE, TYPE_CHAR:
result := FunctionReadUByteIndex(method)(pinfo^.index);
TYPE_USHORT, TYPE_WCHAR:
result := FunctionReadUShortIndex(method)(pinfo^.index);
TYPE_UINT:
result := FunctionReadUIntIndex(method)(pinfo^.index);
TYPE_BYTE:
result := FunctionReadByteIndex(method)(pinfo^.index);
TYPE_SHORT:
result := FunctionReadShortIndex(method)(pinfo^.index);
TYPE_INT:
result := FunctionReadIntIndex(method)(pinfo^.index);
else
result := FunctionReadLongIndex(method)(pinfo^.index);
end;
exit;
end;
case propertyType of
TYPE_UBYTE, TYPE_CHAR:
result := FunctionReadUByteNorm(method)();
TYPE_USHORT, TYPE_WCHAR:
result := FunctionReadUShortNorm(method)();
TYPE_UINT:
result := FunctionReadUIntNorm(method)();
TYPE_BYTE:
result := FunctionReadByteNorm(method)();
TYPE_SHORT:
result := FunctionReadShortNorm(method)();
TYPE_INT:
result := FunctionReadIntNorm(method)();
else
result := FunctionReadLongNorm(method)();
end;
exit;
end;
case propertyType of
TYPE_UBYTE, TYPE_CHAR:
result := system.UInt8(address^);
TYPE_USHORT, TYPE_WCHAR:
result := system.UInt16(address^);
TYPE_UINT:
result := system.UInt32(address^);
TYPE_BYTE:
result := byte(address^);
TYPE_SHORT:
result := short(address^);
TYPE_INT:
result := int(address^);
else
result := long(address^);
end;
end
else
raise IllegalPropertyTypeException.create('TObjectExtended.readPropertyOfLong: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
end;
function TObjectExtended.readPropertyOfDouble(const name: AnsiString): double;
type
FunctionReadFloatIndex = function(index: int): float of object;
FunctionReadDoubleIndex = function(index: int): double of object;
FunctionReadFloatNorm = function(): float of object;
FunctionReadDoubleNorm = function(): double of object;
var
isIndexed: boolean;
transferMethod: int;
propertyType: int;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.readPropertyOfDouble: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
propertyType := ClassInformation.typeInfoToLangType(pinfo^.propType);
case propertyType of
TYPE_FLOAT, TYPE_DOUBLE: begin
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := transferMethod and $03;
case transferMethod of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.readPropertyOfDouble: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
address := Pointer(self) + long((@access)^);
end;
TM_CONST:
address := @(pinfo^.getProc);
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.readPropertyOfDouble: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
case propertyType of
TYPE_FLOAT:
result := FunctionReadFloatIndex(method)(pinfo^.index);
else
result := FunctionReadDoubleIndex(method)(pinfo^.index);
end;
exit;
end;
case propertyType of
TYPE_FLOAT:
result := FunctionReadFloatNorm(method)();
else
result := FunctionReadDoubleNorm(method)();
end;
exit;
end;
case propertyType of
TYPE_FLOAT:
result := float(address^);
else
result := double(address^);
end;
end
else
raise IllegalPropertyTypeException.create('TObjectExtended.readPropertyOfDouble: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
end;
function TObjectExtended.readPropertyOfObject(const name: AnsiString): TObject;
type
FunctionReadObjectIndex = function(index: int): TObject of object;
FunctionReadObjectNorm = function(): TObject of object;
var
isIndexed: boolean;
transferMethod: int;
propertyType: int;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.readPropertyOfObject: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
propertyType := ClassInformation.typeInfoToLangType(pinfo^.propType);
case propertyType of
TYPE_CLASS: begin
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := transferMethod and $03;
case transferMethod of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.readPropertyOfObject: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
address := Pointer(self) + long((@access)^);
end;
TM_CONST:
address := @(pinfo^.getProc);
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.readPropertyOfObject: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
result := FunctionReadObjectIndex(method)(pinfo^.index);
exit;
end;
result := FunctionReadObjectNorm(method)();
exit;
end;
result := TObject(address^);
end
else
raise IllegalPropertyTypeException.create('TObjectExtended.readPropertyOfObject: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
end;
function TObjectExtended.readPropertyOfInterface(const name: AnsiString): IUnknown;
type
FunctionReadInterfaceIndex = function(index: int): IUnknown of object;
FunctionReadInterfaceNorm = function(): IUnknown of object;
var
isIndexed: boolean;
transferMethod: int;
propertyType: int;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.readPropertyOfInterface: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
propertyType := ClassInformation.typeInfoToLangType(pinfo^.propType);
case propertyType of
TYPE_INTERFACE: begin
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := transferMethod and $03;
case transferMethod of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.readPropertyOfInterface: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
address := Pointer(self) + long((@access)^);
end;
TM_CONST:
address := @(pinfo^.getProc);
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.readPropertyOfInterface: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
result := FunctionReadInterfaceIndex(method)(pinfo^.index);
exit;
end;
result := FunctionReadInterfaceNorm(method)();
exit;
end;
result := IUnknown(address^);
end
else
raise IllegalPropertyTypeException.create('TObjectExtended.readPropertyOfInterface: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
end;
function TObjectExtended.readPropertyOfAnsiString(const name: AnsiString): AnsiString;
type
FunctionReadAnsiStringIndex = function(index: int): AnsiString of object;
FunctionReadAnsiStringNorm = function(): AnsiString of object;
var
isIndexed: boolean;
transferMethod: int;
propertyType: int;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.readPropertyOfAnsiString: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
propertyType := ClassInformation.typeInfoToLangType(pinfo^.propType);
case propertyType of
TYPE_ANSISTRING: begin
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := transferMethod and $03;
case transferMethod of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.readPropertyOfAnsiString: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
address := Pointer(self) + long((@access)^);
end;
TM_CONST:
address := @(pinfo^.getProc);
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.readPropertyOfAnsiString: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
result := FunctionReadAnsiStringIndex(method)(pinfo^.index);
exit;
end;
result := FunctionReadAnsiStringNorm(method)();
exit;
end;
result := AnsiString(address^);
end
else
raise IllegalPropertyTypeException.create('TObjectExtended.readPropertyOfAnsiString: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
end;
function TObjectExtended.readPropertyOfUnicodeString(const name: AnsiString): UnicodeString;
type
FunctionReadUnicodeStringIndex = function(index: int): UnicodeString of object;
FunctionReadUnicodeStringNorm = function(): UnicodeString of object;
var
isIndexed: boolean;
transferMethod: int;
propertyType: int;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.readPropertyOfUnicodeString: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
propertyType := ClassInformation.typeInfoToLangType(pinfo^.propType);
case propertyType of
TYPE_UNICODESTRING: begin
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := transferMethod and $03;
case transferMethod of
TM_FIELD: begin
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.readPropertyOfUnicodeString: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
address := Pointer(self) + long((@access)^);
end;
TM_CONST:
address := @(pinfo^.getProc);
else
access := pinfo^.getProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.readPropertyOfUnicodeString: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
result := FunctionReadUnicodeStringIndex(method)(pinfo^.index);
exit;
end;
result := FunctionReadUnicodeStringNorm(method)();
exit;
end;
result := UnicodeString(address^);
end
else
raise IllegalPropertyTypeException.create('TObjectExtended.readPropertyOfUnicodeString: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
end;
procedure TObjectExtended.writePropertyOfBoolean(const name: AnsiString; value: boolean);
type
ProcedureWriteBooleanIndex = procedure(index: int; value: boolean) of object;
ProcedureWriteBooleanNorm = procedure(value: boolean) of object;
var
isIndexed: boolean;
transferMethod: int;
propertyType: int;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.writePropertyOfBoolean: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.writePropertyOfBoolean: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
propertyType := ClassInformation.typeInfoToLangType(pinfo^.propType);
case propertyType of
TYPE_BOOLEAN: begin
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := (transferMethod shr 2) and $03;
case transferMethod of
TM_FIELD: begin
address := Pointer(self) + long((@access)^);
boolean(address^) := value;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
ProcedureWriteBooleanIndex(method)(pinfo^.index, value);
exit;
end;
ProcedureWriteBooleanNorm(method)(value);
end;
end;
end
else
raise IllegalPropertyTypeException.create('TObjectExtended.writePropertyOfBoolean: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
end;
procedure TObjectExtended.writePropertyOfLong(const name: AnsiString; value: long);
type
ProcedureWriteUByteIndex = procedure(index: int; value: system.UInt8) of object;
ProcedureWriteUShortIndex = procedure(index: int; value: system.UInt16) of object;
ProcedureWriteUIntIndex = procedure(index: int; value: system.UInt32) of object;
ProcedureWriteByteIndex = procedure(index: int; value: byte) of object;
ProcedureWriteShortIndex = procedure(index: int; value: short) of object;
ProcedureWriteIntIndex = procedure(index: int; value: int) of object;
ProcedureWriteLongIndex = procedure(index: int; value: long) of object;
ProcedureWriteUByteNorm = procedure(value: system.UInt8) of object;
ProcedureWriteUShortNorm = procedure(value: system.UInt16) of object;
ProcedureWriteUIntNorm = procedure(value: system.UInt32) of object;
ProcedureWriteByteNorm = procedure(value: byte) of object;
ProcedureWriteShortNorm = procedure(value: short) of object;
ProcedureWriteIntNorm = procedure(value: int) of object;
ProcedureWriteLongNorm = procedure(value: long) of object;
var
isIndexed: boolean;
transferMethod: int;
propertyType: int;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.writePropertyOfLong: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.writePropertyOfLong: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
propertyType := ClassInformation.typeInfoToLangType(pinfo^.propType);
case propertyType of
TYPE_CHAR, TYPE_WCHAR, TYPE_BYTE, TYPE_SHORT, TYPE_INT, TYPE_LONG, TYPE_UBYTE, TYPE_USHORT, TYPE_UINT, TYPE_ULONG: begin
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := (transferMethod shr 2) and $03;
case transferMethod of
TM_FIELD: begin
address := Pointer(self) + long((@access)^);
case propertyType of
TYPE_BYTE, TYPE_UBYTE, TYPE_CHAR:
byte(address^) := byte(value);
TYPE_SHORT, TYPE_USHORT, TYPE_WCHAR:
short(address^) := short(value);
TYPE_INT, TYPE_UINT:
int(address^) := int(value);
else
long(address^) := value;
end;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
case propertyType of
TYPE_UBYTE, TYPE_CHAR:
ProcedureWriteUByteIndex(method)(pinfo^.index, system.UInt8(value));
TYPE_USHORT, TYPE_WCHAR:
ProcedureWriteUShortIndex(method)(pinfo^.index, system.UInt16(value));
TYPE_UINT:
ProcedureWriteUIntIndex(method)(pinfo^.index, system.UInt32(value));
TYPE_BYTE:
ProcedureWriteByteIndex(method)(pinfo^.index, byte(value));
TYPE_SHORT:
ProcedureWriteShortIndex(method)(pinfo^.index, short(value));
TYPE_INT:
ProcedureWriteIntIndex(method)(pinfo^.index, int(value));
else
ProcedureWriteLongIndex(method)(pinfo^.index, value);
end;
exit;
end;
case propertyType of
TYPE_UBYTE, TYPE_CHAR:
ProcedureWriteUByteNorm(method)(system.UInt8(value));
TYPE_USHORT, TYPE_WCHAR:
ProcedureWriteUShortNorm(method)(system.UInt16(value));
TYPE_UINT:
ProcedureWriteUIntNorm(method)(system.UInt32(value));
TYPE_BYTE:
ProcedureWriteByteNorm(method)(byte(value));
TYPE_SHORT:
ProcedureWriteShortNorm(method)(short(value));
TYPE_INT:
ProcedureWriteIntNorm(method)(int(value));
else
ProcedureWriteLongNorm(method)(value);
end;
end;
end;
end
else
raise IllegalPropertyTypeException.create('TObjectExtended.writePropertyOfLong: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
end;
procedure TObjectExtended.writePropertyOfDouble(const name: AnsiString; value: double);
type
ProcedureWriteFloatIndex = procedure(index: int; value: float) of object;
ProcedureWriteDoubleIndex = procedure(index: int; value: double) of object;
ProcedureWriteFloatNorm = procedure(value: float) of object;
ProcedureWriteDoubleNorm = procedure(value: double) of object;
var
isIndexed: boolean;
transferMethod: int;
propertyType: int;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.writePropertyOfDouble: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.writePropertyOfDouble: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
propertyType := ClassInformation.typeInfoToLangType(pinfo^.propType);
case propertyType of
TYPE_FLOAT, TYPE_DOUBLE: begin
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := (transferMethod shr 2) and $03;
case transferMethod of
TM_FIELD: begin
address := Pointer(self) + long((@access)^);
case propertyType of
TYPE_FLOAT:
float(address^) := doubleToFloat(value);
else
double(address^) := value;
end;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
case propertyType of
TYPE_FLOAT:
ProcedureWriteFloatIndex(method)(pinfo^.index, doubleToFloat(value));
else
ProcedureWriteDoubleIndex(method)(pinfo^.index, value);
end;
exit;
end;
case propertyType of
TYPE_FLOAT:
ProcedureWriteFloatNorm(method)(doubleToFloat(value));
else
ProcedureWriteDoubleNorm(method)(value);
end;
end;
end;
end
else
raise IllegalPropertyTypeException.create('TObjectExtended.writePropertyOfDouble: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
end;
procedure TObjectExtended.writePropertyOfObject(const name: AnsiString; value: TObject);
type
ProcedureWriteObjectIndex = procedure(index: int; value: TObject) of object;
ProcedureWriteObjectNorm = procedure(value: TObject) of object;
var
isIndexed: boolean;
transferMethod: int;
propertyType: int;
propertyTypeExt: PTypeInfo;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.writePropertyOfObject: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.writePropertyOfObject: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
propertyTypeExt := pinfo^.propType;
propertyType := ClassInformation.typeInfoToLangType(propertyTypeExt);
case propertyType of
TYPE_CLASS: begin
if (value <> nil) and not (ClassInformation.create(getTypeData(propertyTypeExt)^.classType) as _Class).isAssignableFrom(value.getClass()) then begin
raise IllegalPropertyTypeException.create('TObjectExtended.writePropertyOfObject: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := (transferMethod shr 2) and $03;
case transferMethod of
TM_FIELD: begin
address := Pointer(self) + long((@access)^);
TObject(address^) := value;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
ProcedureWriteObjectIndex(method)(pinfo^.index, value);
exit;
end;
ProcedureWriteObjectNorm(method)(value);
end;
end;
end
else
raise IllegalPropertyTypeException.create('TObjectExtended.writePropertyOfObject: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
end;
procedure TObjectExtended.writePropertyOfInterface(const name: AnsiString; value: IUnknown);
type
ProcedureWriteInterfaceIndex = procedure(index: int; value: IUnknown) of object;
ProcedureWriteInterfaceNorm = procedure(value: IUnknown) of object;
var
isIndexed: boolean;
transferMethod: int;
propertyType: int;
propertyTypeExt: PTypeInfo;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
newvalue: IUnknown;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.writePropertyOfInterface: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.writePropertyOfInterface: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
propertyTypeExt := pinfo^.propType;
propertyType := ClassInformation.typeInfoToLangType(propertyTypeExt);
case propertyType of
TYPE_INTERFACE: begin
newvalue := nil;
if (value <> nil) and (value.queryInterface(getTypeData(propertyTypeExt)^.guid, newvalue) <> S_OK) then begin
raise IllegalPropertyTypeException.create('TObjectExtended.writePropertyOfInterface: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := (transferMethod shr 2) and $03;
case transferMethod of
TM_FIELD: begin
address := Pointer(self) + long((@access)^);
IUnknown(address^) := newvalue;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
ProcedureWriteInterfaceIndex(method)(pinfo^.index, newvalue);
exit;
end;
ProcedureWriteInterfaceNorm(method)(newvalue);
end;
end;
end
else
raise IllegalPropertyTypeException.create('TObjectExtended.writePropertyOfInterface: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
end;
procedure TObjectExtended.writePropertyOfAnsiString(const name: AnsiString; const value: AnsiString);
type
ProcedureWriteAnsiStringIndex = procedure(index: int; value: AnsiString) of object;
ProcedureWriteAnsiStringNorm = procedure(value: AnsiString) of object;
var
isIndexed: boolean;
transferMethod: int;
propertyType: int;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.writePropertyOfAnsiString: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.writePropertyOfAnsiString: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
propertyType := ClassInformation.typeInfoToLangType(pinfo^.propType);
case propertyType of
TYPE_ANSISTRING: begin
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := (transferMethod shr 2) and $03;
case transferMethod of
TM_FIELD: begin
address := Pointer(self) + long((@access)^);
AnsiString(address^) := value;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
ProcedureWriteAnsiStringIndex(method)(pinfo^.index, value);
exit;
end;
ProcedureWriteAnsiStringNorm(method)(value);
end;
end;
end
else
raise IllegalPropertyTypeException.create('TObjectExtended.writePropertyOfAnsiString: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
end;
procedure TObjectExtended.writePropertyOfUnicodeString(const name: AnsiString; const value: UnicodeString);
type
ProcedureWriteUnicodeStringIndex = procedure(index: int; value: UnicodeString) of object;
ProcedureWriteUnicodeStringNorm = procedure(value: UnicodeString) of object;
var
isIndexed: boolean;
transferMethod: int;
propertyType: int;
access: CodePointer;
pinfo: PPropInfo;
address: Pointer;
method: TMethod;
begin
pinfo := getPropertyInfo(name);
if pinfo = nil then begin
raise PropertyNotFoundException.create('TObjectExtended.writePropertyOfUnicodeString: ' + msgPropertyNotFound + getClass().getCanonicalName() + '.' + name);
end;
access := pinfo^.setProc;
if access = nil then begin
raise IllegalPropertyAccessException.create('TObjectExtended.writePropertyOfUnicodeString: ' + msgIllegalPropertyAccess + getClass().getCanonicalName() + '.' + name);
end;
propertyType := ClassInformation.typeInfoToLangType(pinfo^.propType);
case propertyType of
TYPE_UNICODESTRING: begin
transferMethod := pinfo^.propProcs;
isIndexed := (transferMethod and $40) <> 0;
transferMethod := (transferMethod shr 2) and $03;
case transferMethod of
TM_FIELD: begin
address := Pointer(self) + long((@access)^);
UnicodeString(address^) := value;
end;
TM_SPECIAL, TM_VIRTUAL: begin
if transferMethod = TM_SPECIAL then begin
method.code := access;
end else begin
method.code := CodePointer((Pointer(self.classType()) + long((@access)^))^);
end;
method.data := self;
if isIndexed then begin
ProcedureWriteUnicodeStringIndex(method)(pinfo^.index, value);
exit;
end;
ProcedureWriteUnicodeStringNorm(method)(value);
end;
end;
end
else
raise IllegalPropertyTypeException.create('TObjectExtended.writePropertyOfUnicodeString: ' + msgIllegalPropertyType + getClass().getCanonicalName() + '.' + name);
end;
end;
{%endregion}
{%region _Object }
constructor _Object.create();
begin
inherited create();
end;
destructor _Object.destroy;
begin
inherited destroy;
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() + '@' + longToHexString(getHashCode());
end;
function _Object.queryInterface({$IFDEF FPC_HAS_CONSTREF} constref {$ELSE} const {$ENDIF} iid: TGuid; out obj): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF};
begin
if getInterface(iid, obj) then begin
result := S_OK;
end else begin
result := E_NOINTERFACE;
end;
end;
function _Object._addref(): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF};
begin
result := -1;
end;
function _Object._release(): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF};
begin
result := -1;
end;
procedure _Object.afterConstruction();
begin
end;
procedure _Object.beforeDestruction();
begin
end;
{%endregion}
{%region RefCountInterfacedObject }
class function RefCountInterfacedObject.newInstance(): TObject;
begin
result := inherited newInstance();
if result <> nil then begin
RefCountInterfacedObject(result).refcount := 1;
end;
end;
function RefCountInterfacedObject._addref(): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF};
begin
result := interlockedIncrement(@refcount);
end;
function RefCountInterfacedObject._release(): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF};
begin
result := interlockedDecrement(@refcount);
if result = 0 then destroy;
end;
procedure RefCountInterfacedObject.afterConstruction(); assembler; nostackframe;
asm
lock dec dword[rcx+offset refcount]
end;
procedure RefCountInterfacedObject.beforeDestruction();
begin
if refcount <> 0 then begin
raise RuntimeException.create('Error 204 (refcount != 0)');
end;
end;
{%endregion}
{%region DynamicalyAllocatedObject }
constructor DynamicalyAllocatedObject.create();
begin
inherited create();
end;
{%endregion}
{%region ValueOfBoolean }
constructor ValueOfBoolean.create(value: boolean);
begin
inherited create();
if value then begin
self.value := -1;
end else begin
self.value := 0;
end;
end;
function ValueOfBoolean.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is ValueOfBoolean) and (ValueOfBoolean(anot).value = value);
end;
function ValueOfBoolean.getHashCode(): long;
begin
if value = 0 then begin
result := 1237;
exit;
end;
result := 1231;
end;
function ValueOfBoolean.toString(): AnsiString;
begin
if value = 0 then begin
result := 'false';
exit;
end;
result := 'true';
end;
function ValueOfBoolean.getType(): int;
begin
result := TYPE_BOOLEAN;
end;
function ValueOfBoolean.booleanValue(): boolean;
begin
result := value <> 0;
end;
function ValueOfBoolean.intValue(): int;
begin
result := value;
end;
function ValueOfBoolean.longValue(): long;
begin
result := value;
end;
function ValueOfBoolean.floatValue(): float;
begin
result := intToFloat(value);
end;
function ValueOfBoolean.doubleValue(): double;
begin
result := intToDouble(value);
end;
function ValueOfBoolean.realValue(): real;
begin
result := value;
end;
function ValueOfBoolean.ansiStringValue(): AnsiString;
begin
if value = 0 then begin
result := 'false';
exit;
end;
result := 'true';
end;
function ValueOfBoolean.unicodeStringValue(): UnicodeString;
begin
if value = 0 then begin
result := 'false';
exit;
end;
result := 'true';
end;
function ValueOfBoolean.objectValue(): TObject;
begin
result := self;
end;
function ValueOfBoolean.interfaceValue(): IUnknown;
begin
result := self;
end;
function ValueOfBoolean.getSize(): int;
begin
result := 1;
end;
procedure ValueOfBoolean.writeToByteArray(const dst: byte_Array1d; offset: int);
begin
arrayCheckBounds('ValueOfBoolean.writeToByteArray', system.length(dst), offset, 1);
dst[offset] := value;
end;
procedure ValueOfBoolean.writeToByteArrayLE(const dst: byte_Array1d; offset: int);
begin
arrayCheckBounds('ValueOfBoolean.writeToByteArrayLE', system.length(dst), offset, 1);
dst[offset] := value;
end;
{%endregion}
{%region ValueOfLong }
constructor ValueOfLong.create(value: long; &type: int);
begin
inherited create();
if (value >= BYTE_MIN_VALUE) and (value <= BYTE_MAX_VALUE) then begin
if (&type <> TYPE_SHORT) and (&type <> TYPE_INT) and (&type <> TYPE_LONG) then &type := TYPE_BYTE;
end else
if (value >= SHORT_MIN_VALUE) and (value <= SHORT_MAX_VALUE) then begin
if (&type <> TYPE_INT) and (&type <> TYPE_LONG) then &type := TYPE_SHORT;
end else
if (value >= INT_MIN_VALUE) and (value <= INT_MAX_VALUE) then begin
if &type <> TYPE_LONG then &type := TYPE_INT;
end else begin
&type := TYPE_LONG;
end;
self.value := value;
self.&type := &type;
end;
function ValueOfLong.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is ValueOfLong) and (ValueOfLong(anot).value = value);
end;
function ValueOfLong.getHashCode(): long;
begin
result := value;
end;
function ValueOfLong.toString(): AnsiString;
begin
result := longToString(value);
end;
function ValueOfLong.getType(): int;
begin
result := &type;
end;
function ValueOfLong.booleanValue(): boolean;
begin
result := value <> 0;
end;
function ValueOfLong.intValue(): int;
begin
result := int(value);
end;
function ValueOfLong.longValue(): long;
begin
result := value;
end;
function ValueOfLong.floatValue(): float;
begin
result := longToFloat(value);
end;
function ValueOfLong.doubleValue(): double;
begin
result := longToDouble(value);
end;
function ValueOfLong.realValue(): real;
begin
result := value;
end;
function ValueOfLong.ansiStringValue(): AnsiString;
begin
result := longToString(value);
end;
function ValueOfLong.unicodeStringValue(): UnicodeString;
begin
result := stringToUTF16(longToString(value));
end;
function ValueOfLong.objectValue(): TObject;
begin
result := self;
end;
function ValueOfLong.interfaceValue(): IUnknown;
begin
result := self;
end;
function ValueOfLong.getSize(): int;
begin
case &type of
TYPE_BYTE:
result := 1;
TYPE_SHORT:
result := 2;
TYPE_INT:
result := 4;
else
result := 8;
end;
end;
procedure ValueOfLong.writeToByteArray(const dst: byte_Array1d; offset: int);
begin
case &type of
TYPE_BYTE: begin
arrayCheckBounds('ValueOfLong.writeToByteArray', system.length(dst), offset, 1);
dst[offset] := byte(value);
end;
TYPE_SHORT: begin
arrayCheckBounds('ValueOfLong.writeToByteArray', system.length(dst), offset, 2);
short((@(dst[offset]))^) := shortByteSwap(short(value));
end;
TYPE_INT: begin
arrayCheckBounds('ValueOfLong.writeToByteArray', system.length(dst), offset, 4);
int((@(dst[offset]))^) := intByteSwap(int(value));
end
else
arrayCheckBounds('ValueOfLong.writeToByteArray', system.length(dst), offset, 8);
long((@(dst[offset]))^) := longByteSwap(value);
end;
end;
procedure ValueOfLong.writeToByteArrayLE(const dst: byte_Array1d; offset: int);
begin
case &type of
TYPE_BYTE: begin
arrayCheckBounds('ValueOfLong.writeToByteArrayLE', system.length(dst), offset, 1);
dst[offset] := byte(value);
end;
TYPE_SHORT: begin
arrayCheckBounds('ValueOfLong.writeToByteArrayLE', system.length(dst), offset, 2);
short((@(dst[offset]))^) := short(value);
end;
TYPE_INT: begin
arrayCheckBounds('ValueOfLong.writeToByteArrayLE', system.length(dst), offset, 4);
int((@(dst[offset]))^) := int(value);
end
else
arrayCheckBounds('ValueOfLong.writeToByteArrayLE', system.length(dst), offset, 8);
long((@(dst[offset]))^) := value;
end;
end;
{%endregion}
{%region ValueOfFloat }
constructor ValueOfFloat.create(value: float);
begin
inherited create();
self.value := value;
end;
function ValueOfFloat.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is ValueOfFloat) and (floatToIntBits(ValueOfFloat(anot).value) = floatToIntBits(value));
end;
function ValueOfFloat.getHashCode(): long;
begin
result := floatToIntBits(value);
end;
function ValueOfFloat.toString(): AnsiString;
begin
result := floatRepresenter.toString(value);
end;
function ValueOfFloat.getType(): int;
begin
result := TYPE_FLOAT;
end;
function ValueOfFloat.booleanValue(): boolean;
begin
result := value <> 0.0;
end;
function ValueOfFloat.intValue(): int;
begin
result := floatToInt(value);
end;
function ValueOfFloat.longValue(): long;
begin
result := floatToLong(value);
end;
function ValueOfFloat.floatValue(): float;
begin
result := value;
end;
function ValueOfFloat.doubleValue(): double;
begin
result := value;
end;
function ValueOfFloat.realValue(): real;
begin
result := value;
end;
function ValueOfFloat.ansiStringValue(): AnsiString;
begin
result := floatRepresenter.toString(value);
end;
function ValueOfFloat.unicodeStringValue(): UnicodeString;
begin
result := stringToUTF16(floatRepresenter.toString(value));
end;
function ValueOfFloat.objectValue(): TObject;
begin
result := self;
end;
function ValueOfFloat.interfaceValue(): IUnknown;
begin
result := self;
end;
function ValueOfFloat.getSize(): int;
begin
result := 4;
end;
procedure ValueOfFloat.writeToByteArray(const dst: byte_Array1d; offset: int);
begin
arrayCheckBounds('ValueOfFloat.writeToByteArray', system.length(dst), offset, 4);
int((@(dst[offset]))^) := intByteSwap(floatToIntBits(value));
end;
procedure ValueOfFloat.writeToByteArrayLE(const dst: byte_Array1d; offset: int);
begin
arrayCheckBounds('ValueOfFloat.writeToByteArrayLE', system.length(dst), offset, 4);
int((@(dst[offset]))^) := floatToIntBits(value);
end;
{%endregion}
{%region ValueOfDouble }
constructor ValueOfDouble.create(value: double);
begin
inherited create();
self.value := value;
end;
function ValueOfDouble.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is ValueOfDouble) and (doubleToLongBits(ValueOfDouble(anot).value) = doubleToLongBits(value));
end;
function ValueOfDouble.getHashCode(): long;
begin
result := doubleToLongBits(value);
end;
function ValueOfDouble.toString(): AnsiString;
begin
result := doubleRepresenter.toString(value);
end;
function ValueOfDouble.getType(): int;
begin
result := TYPE_DOUBLE;
end;
function ValueOfDouble.booleanValue(): boolean;
begin
result := value <> 0.0;
end;
function ValueOfDouble.intValue(): int;
begin
result := doubleToInt(value);
end;
function ValueOfDouble.longValue(): long;
begin
result := doubleToLong(value);
end;
function ValueOfDouble.floatValue(): float;
begin
result := doubleToFloat(value);
end;
function ValueOfDouble.doubleValue(): double;
begin
result := value;
end;
function ValueOfDouble.realValue(): real;
begin
result := value;
end;
function ValueOfDouble.ansiStringValue(): AnsiString;
begin
result := doubleRepresenter.toString(value);
end;
function ValueOfDouble.unicodeStringValue(): UnicodeString;
begin
result := stringToUTF16(doubleRepresenter.toString(value));
end;
function ValueOfDouble.objectValue(): TObject;
begin
result := self;
end;
function ValueOfDouble.interfaceValue(): IUnknown;
begin
result := self;
end;
function ValueOfDouble.getSize(): int;
begin
result := 8;
end;
procedure ValueOfDouble.writeToByteArray(const dst: byte_Array1d; offset: int);
begin
arrayCheckBounds('ValueOfDouble.writeToByteArray', system.length(dst), offset, 8);
long((@(dst[offset]))^) := longByteSwap(doubleToLongBits(value));
end;
procedure ValueOfDouble.writeToByteArrayLE(const dst: byte_Array1d; offset: int);
begin
arrayCheckBounds('ValueOfDouble.writeToByteArrayLE', system.length(dst), offset, 8);
long((@(dst[offset]))^) := doubleToLongBits(value);
end;
{%endregion}
{%region ValueOfReal }
class function ValueOfReal.realIsEquals(const value1, value2: real): boolean;
begin
result := arrayequalsf(@value1, @value2, 1, 5) = -1;
end;
constructor ValueOfReal.create(const value: real);
begin
inherited create();
self.value := value;
end;
function ValueOfReal.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is ValueOfReal) and realIsEquals(ValueOfReal(anot).value, value);
end;
function ValueOfReal.getHashCode(): long;
begin
result := realSignificand(value) xor not realExponent(value);
end;
function ValueOfReal.toString(): AnsiString;
begin
result := realRepresenter.toString(value);
end;
function ValueOfReal.getType(): int;
begin
result := TYPE_REAL;
end;
function ValueOfReal.booleanValue(): boolean;
begin
result := value <> realBuild(0, 0);
end;
function ValueOfReal.intValue(): int;
begin
result := realToInt(value);
end;
function ValueOfReal.longValue(): long;
begin
result := realToLong(value);
end;
function ValueOfReal.floatValue(): float;
begin
result := realToFloat(value);
end;
function ValueOfReal.doubleValue(): double;
begin
result := realToDouble(value);
end;
function ValueOfReal.realValue(): real;
begin
result := value;
end;
function ValueOfReal.ansiStringValue(): AnsiString;
begin
result := realRepresenter.toString(value);
end;
function ValueOfReal.unicodeStringValue(): UnicodeString;
begin
result := stringToUTF16(realRepresenter.toString(value));
end;
function ValueOfReal.objectValue(): TObject;
begin
result := self;
end;
function ValueOfReal.interfaceValue(): IUnknown;
begin
result := self;
end;
function ValueOfReal.getSize(): int;
begin
result := 10;
end;
procedure ValueOfReal.writeToByteArray(const dst: byte_Array1d; offset: int);
var
i: int;
j: int;
begin
arrayCheckBounds('ValueOfReal.writeToByteArray', system.length(dst), offset, 10);
i := offset + 9;
j := 0;
while j < 10 do begin
dst[i] := value[j];
dec(i);
inc(j);
end;
end;
procedure ValueOfReal.writeToByteArrayLE(const dst: byte_Array1d; offset: int);
var
i: int;
j: int;
begin
arrayCheckBounds('ValueOfReal.writeToByteArrayLE', system.length(dst), offset, 10);
i := offset;
j := 0;
while j < 10 do begin
dst[i] := value[j];
inc(i);
inc(j);
end;
end;
{%endregion}
{%region ValueOfAnsiString }
constructor ValueOfAnsiString.create(const value: AnsiString);
begin
inherited create();
self.value := value;
end;
function ValueOfAnsiString.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is ValueOfAnsiString) and (ValueOfAnsiString(anot).value = value);
end;
function ValueOfAnsiString.getHashCode(): long;
var
i: int;
e: long;
c: AnsiString;
begin
result := 0;
c := value;
e := 1;
for i := length(c) - 1 downto 0 do begin
inc(result, e * int(c[i + 1]));
e := 31 * e;
end;
end;
function ValueOfAnsiString.toString(): AnsiString;
begin
result := value;
end;
function ValueOfAnsiString.getType(): int;
begin
result := TYPE_ANSISTRING;
end;
function ValueOfAnsiString.booleanValue(): boolean;
begin
result := stringToLowerCase(value) = 'true';
end;
function ValueOfAnsiString.intValue(): int;
begin
try
result := intParse(value);
except
result := 0;
end;
end;
function ValueOfAnsiString.longValue(): long;
begin
try
result := longParse(value);
except
result := 0;
end;
end;
function ValueOfAnsiString.floatValue(): float;
begin
try
result := floatParse(value);
except
result := 0.0;
end;
end;
function ValueOfAnsiString.doubleValue(): double;
begin
try
result := doubleParse(value);
except
result := 0.0;
end;
end;
function ValueOfAnsiString.realValue(): real;
begin
try
result := realParse(value);
except
result := realBuild(0, 0);
end;
end;
function ValueOfAnsiString.ansiStringValue(): AnsiString;
begin
result := value;
end;
function ValueOfAnsiString.unicodeStringValue(): UnicodeString;
begin
result := stringToUTF16(value);
end;
function ValueOfAnsiString.objectValue(): TObject;
begin
result := self;
end;
function ValueOfAnsiString.interfaceValue(): IUnknown;
begin
result := self;
end;
{%endregion}
{%region ValueOfUnicodeString }
constructor ValueOfUnicodeString.create(const value: UnicodeString);
begin
inherited create();
self.value := value;
end;
function ValueOfUnicodeString.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is ValueOfUnicodeString) and (ValueOfUnicodeString(anot).value = value);
end;
function ValueOfUnicodeString.getHashCode(): long;
var
i: int;
e: long;
c: UnicodeString;
begin
result := 0;
c := value;
e := 1;
for i := length(c) - 1 downto 0 do begin
inc(result, e * int(c[i + 1]));
e := 31 * e;
end;
end;
function ValueOfUnicodeString.toString(): AnsiString;
begin
result := stringToUTF8(value);
end;
function ValueOfUnicodeString.getType(): int;
begin
result := TYPE_UNICODESTRING;
end;
function ValueOfUnicodeString.booleanValue(): boolean;
begin
result := stringToLowerCase(value) = 'true';
end;
function ValueOfUnicodeString.intValue(): int;
begin
try
result := intParse(stringToUTF8(value));
except
result := 0;
end;
end;
function ValueOfUnicodeString.longValue(): long;
begin
try
result := longParse(stringToUTF8(value));
except
result := 0;
end;
end;
function ValueOfUnicodeString.floatValue(): float;
begin
try
result := floatParse(stringToUTF8(value));
except
result := 0.0;
end;
end;
function ValueOfUnicodeString.doubleValue(): double;
begin
try
result := doubleParse(stringToUTF8(value));
except
result := 0.0;
end;
end;
function ValueOfUnicodeString.realValue(): real;
begin
try
result := realParse(stringToUTF8(value));
except
result := realBuild(0, 0);
end;
end;
function ValueOfUnicodeString.ansiStringValue(): AnsiString;
begin
result := stringToUTF8(value);
end;
function ValueOfUnicodeString.unicodeStringValue(): UnicodeString;
begin
result := value;
end;
function ValueOfUnicodeString.objectValue(): TObject;
begin
result := self;
end;
function ValueOfUnicodeString.interfaceValue(): IUnknown;
begin
result := self;
end;
{%endregion}
{%region ValueOfObject }
constructor ValueOfObject.create(value: TObject; owned: boolean);
begin
inherited create();
self.value := value;
self.owned := owned;
end;
destructor ValueOfObject.destroy;
begin
if owned then value.free();
value := nil;
inherited destroy;
end;
function ValueOfObject.equals(anot: TObject): boolean;
var
lValue: TObject;
begin
lValue := self.value;
result := (anot = self) or (anot is ValueOfObject) and ((lValue = nil) and (ValueOfObject(anot).value = nil) or (lValue <> nil) and (lValue.equals(ValueOfObject(anot).value)));
end;
function ValueOfObject.getHashCode(): long;
var
lValue: TObject;
begin
lValue := self.value;
if lValue = nil then begin
result := 0;
exit;
end;
result := lValue.getHashCode();
end;
function ValueOfObject.toString(): AnsiString;
var
lValue: TObject;
begin
lValue := self.value;
if lValue = nil then begin
result := 'null';
exit;
end;
result := lValue.toString();
end;
function ValueOfObject.getType(): int;
begin
result := TYPE_CLASS;
end;
function ValueOfObject.booleanValue(): boolean;
begin
result := false;
end;
function ValueOfObject.intValue(): int;
begin
result := 0;
end;
function ValueOfObject.longValue(): long;
begin
result := 0;
end;
function ValueOfObject.floatValue(): float;
begin
result := 0.0;
end;
function ValueOfObject.doubleValue(): double;
begin
result := 0.0;
end;
function ValueOfObject.realValue(): real;
begin
result := realBuild(0, 0);
end;
function ValueOfObject.ansiStringValue(): AnsiString;
begin
result := '';
end;
function ValueOfObject.unicodeStringValue(): UnicodeString;
begin
result := '';
end;
function ValueOfObject.objectValue(): TObject;
begin
result := value;
end;
function ValueOfObject.interfaceValue(): IUnknown;
var
ival: IUnknown;
oval: TObject;
begin
ival := nil;
oval := value;
if oval <> nil then begin
oval.getInterface(IUnknown, ival);
end;
result := ival;
end;
{%endregion}
{%region ValueOfInterface }
constructor ValueOfInterface.create(value: IUnknown);
begin
inherited create();
self.value := value as IUnknown;
end;
function ValueOfInterface.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is ValueOfInterface) and (ValueOfInterface(anot).value = value);
end;
function ValueOfInterface.getHashCode(): long;
begin
result := long(value);
end;
function ValueOfInterface.toString(): AnsiString;
var
lValue: IUnknown;
begin
lValue := self.value;
if lValue = nil then begin
result := 'null';
exit;
end;
result := classForName('system.IUnknown').getCanonicalName() + '@' + longToHexString(long(lValue));
end;
function ValueOfInterface.getType(): int;
begin
result := TYPE_INTERFACE;
end;
function ValueOfInterface.booleanValue(): boolean;
begin
result := false;
end;
function ValueOfInterface.intValue(): int;
begin
result := 0;
end;
function ValueOfInterface.longValue(): long;
begin
result := 0;
end;
function ValueOfInterface.floatValue(): float;
begin
result := 0.0;
end;
function ValueOfInterface.doubleValue(): double;
begin
result := 0.0;
end;
function ValueOfInterface.realValue(): real;
begin
result := realBuild(0, 0);
end;
function ValueOfInterface.ansiStringValue(): AnsiString;
begin
result := '';
end;
function ValueOfInterface.unicodeStringValue(): UnicodeString;
begin
result := '';
end;
function ValueOfInterface.objectValue(): TObject;
var
ival: IUnknown;
oval: TObject;
begin
ival := value;
oval := nil;
if ival is TObject then begin
oval := ival as TObject;
end;
result := oval;
end;
function ValueOfInterface.interfaceValue(): IUnknown;
begin
result := value;
end;
{%endregion}
{%region RealValueRepresenter }
class function RealValueRepresenter.pow10(const value: real; power: int): real;
begin
if power = INT_MIN_VALUE then begin
result := value * realBuild(0, 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) * REAL_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) * realBuild(0, 0);
exit;
end;
result := value / tab_04_00(power) / tab_08_05(power) / tab_12_09(power);
exit;
end;
result := value;
end;
class function RealValueRepresenter.tab_04_00(power: int): real;
begin
case power and $1f of
0: result := realBuild($3fff, $8000000000000000); { 1.e+0000 }
1: result := realBuild($4002, $a000000000000000); { 1.e+0001 }
2: result := realBuild($4005, $c800000000000000); { 1.e+0002 }
3: result := realBuild($4008, $fa00000000000000); { 1.e+0003 }
4: result := realBuild($400c, $9c40000000000000); { 1.e+0004 }
5: result := realBuild($400f, $c350000000000000); { 1.e+0005 }
6: result := realBuild($4012, $f424000000000000); { 1.e+0006 }
7: result := realBuild($4016, $9896800000000000); { 1.e+0007 }
8: result := realBuild($4019, $bebc200000000000); { 1.e+0008 }
9: result := realBuild($401c, $ee6b280000000000); { 1.e+0009 }
10: result := realBuild($4020, $9502f90000000000); { 1.e+0010 }
11: result := realBuild($4023, $ba43b74000000000); { 1.e+0011 }
12: result := realBuild($4026, $e8d4a51000000000); { 1.e+0012 }
13: result := realBuild($402a, $9184e72a00000000); { 1.e+0013 }
14: result := realBuild($402d, $b5e620f480000000); { 1.e+0014 }
15: result := realBuild($4030, $e35fa931a0000000); { 1.e+0015 }
16: result := realBuild($4034, $8e1bc9bf04000000); { 1.e+0016 }
17: result := realBuild($4037, $b1a2bc2ec5000000); { 1.e+0017 }
18: result := realBuild($403a, $de0b6b3a76400000); { 1.e+0018 }
19: result := realBuild($403e, $8ac7230489e80000); { 1.e+0019 }
20: result := realBuild($4041, $ad78ebc5ac620000); { 1.e+0020 }
21: result := realBuild($4044, $d8d726b7177a8000); { 1.e+0021 }
22: result := realBuild($4048, $878678326eac9000); { 1.e+0022 }
23: result := realBuild($404b, $a968163f0a57b400); { 1.e+0023 }
24: result := realBuild($404e, $d3c21bcecceda100); { 1.e+0024 }
25: result := realBuild($4052, $84595161401484a0); { 1.e+0025 }
26: result := realBuild($4055, $a56fa5b99019a5c8); { 1.e+0026 }
27: result := realBuild($4058, $cecb8f27f4200f3a); { 1.e+0027 }
28: result := realBuild($405c, $813f3978f8940984); { 1.e+0028 }
29: result := realBuild($405f, $a18f07d736b90be5); { 1.e+0029 }
30: result := realBuild($4062, $c9f2c9cd04674edf); { 1.e+0030 }
31: result := realBuild($4065, $fc6f7c4045812296); { 1.e+0031 }
else result := realBuild($0000, $0000000000000000); { 0.0 }
end;
end;
class function RealValueRepresenter.tab_08_05(power: int): real;
begin
case (power shr 5) and $0f of
0: result := realBuild($3fff, $8000000000000000); { 1.e+0000 }
1: result := realBuild($4069, $9dc5ada82b70b59e); { 1.e+0032 }
2: result := realBuild($40d3, $c2781f49ffcfa6d5); { 1.e+0064 }
3: result := realBuild($413d, $efb3ab16c59b14a3); { 1.e+0096 }
4: result := realBuild($41a8, $93ba47c980e98ce0); { 1.e+0128 }
5: result := realBuild($4212, $b616a12b7fe617aa); { 1.e+0160 }
6: result := realBuild($427c, $e070f78d3927556b); { 1.e+0192 }
7: result := realBuild($42e7, $8a5296ffe33cc930); { 1.e+0224 }
8: result := realBuild($4351, $aa7eebfb9df9de8e); { 1.e+0256 }
9: result := realBuild($43bb, $d226fc195c6a2f8c); { 1.e+0288 }
10: result := realBuild($4426, $81842f29f2cce376); { 1.e+0320 }
11: result := realBuild($4490, $9fa42700db900ad2); { 1.e+0352 }
12: result := realBuild($44fa, $c4c5e310aef8aa17); { 1.e+0384 }
13: result := realBuild($4564, $f28a9c07e9b09c59); { 1.e+0416 }
14: result := realBuild($45cf, $957a4ae1ebf7f3d4); { 1.e+0448 }
15: result := realBuild($4639, $b83ed8dc0795a262); { 1.e+0480 }
else result := realBuild($0000, $0000000000000000); { 0.0 }
end;
end;
class function RealValueRepresenter.tab_12_09(power: int): real;
begin
case (power shr 9) and $0f of
0: result := realBuild($3fff, $8000000000000000); { 1.e+0000 }
1: result := realBuild($46a3, $e319a0aea60e91c7); { 1.e+0512 }
2: result := realBuild($4d48, $c976758681750c17); { 1.e+1024 }
3: result := realBuild($53ed, $b2b8353b3993a7e4); { 1.e+1536 }
4: result := realBuild($5a92, $9e8b3b5dc53d5de5); { 1.e+2048 }
5: result := realBuild($6137, $8ca554c020a1f0a6); { 1.e+2560 }
6: result := realBuild($67db, $f9895d25d88b5a8b); { 1.e+3072 }
7: result := realBuild($6e80, $dd5dc8a2bf27f3f8); { 1.e+3584 }
8: result := realBuild($7525, $c46052028a20979b); { 1.e+4096 }
9: result := realBuild($7bca, $ae3511626ed559f0); { 1.e+4608 }
else result := REAL_POSITIVE_INFINITY;
end;
end;
constructor RealValueRepresenter.create(significandDigits, orderDigits: int; orderRequired: boolean);
var
i: int;
maxValue: long;
begin
inherited create();
if significandDigits < MIN_SIGNIFICAND_DIGITS then significandDigits := MIN_SIGNIFICAND_DIGITS;
if significandDigits > MAX_SIGNIFICAND_DIGITS then significandDigits := MAX_SIGNIFICAND_DIGITS;
if orderDigits < MIN_ORDER_DIGITS then orderDigits := MIN_ORDER_DIGITS;
if orderDigits > MAX_ORDER_DIGITS then orderDigits := MAX_ORDER_DIGITS;
maxValue := 1;
for i := significandDigits downto 1 do maxValue := maxValue * 10;
self.limitValueWithFractialPart := pow10(1.0, significandDigits - 1);
self.limitValueWithoutExponent := pow10(1.0, significandDigits);
self.minRepresentValue := maxValue div 10;
self.maxRepresentValue := maxValue - 1;
self.significandDigits := significandDigits;
self.orderDigits := orderDigits;
self.orderRequired := orderRequired;
end;
function RealValueRepresenter.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is RealValueRepresenter) and (RealValueRepresenter(anot).orderDigits = orderDigits) and (RealValueRepresenter(anot).significandDigits = significandDigits);
end;
function RealValueRepresenter.getHashCode(): long;
begin
result := (orderDigits shl 8) or significandDigits;
end;
function RealValueRepresenter.parseReal(const str: AnsiString): real;
begin
if (str = '+Infinity') or (str = 'Infinity') then begin
result := REAL_POSITIVE_INFINITY;
exit;
end;
if str = '-Infinity' then begin
result := REAL_NEGATIVE_INFINITY;
exit;
end;
if str = 'NaN' then begin
result := REAL_NAN;
exit;
end;
result := parse(str);
if (result < -REAL_MAX_VALUE) or (result > REAL_MAX_VALUE) then begin
raise NumberFormatException.create('RealValueRepresenter.parse: ' + msgIllegalNumberFormat);
end;
end;
function RealValueRepresenter.parseFloat(const str: AnsiString): float;
var
value: real;
begin
if (str = '+Infinity') or (str = 'Infinity') then begin
result := FLOAT_POSITIVE_INFINITY;
exit;
end;
if str = '-Infinity' then begin
result := FLOAT_NEGATIVE_INFINITY;
exit;
end;
if str = 'NaN' then begin
result := FLOAT_NAN;
exit;
end;
value := parse(str);
if (value < -FLOAT_MAX_VALUE) or (value > FLOAT_MAX_VALUE) then begin
raise NumberFormatException.create('RealValueRepresenter.parse: ' + msgIllegalNumberFormat);
end;
result := realToFloat(value);
end;
function RealValueRepresenter.parseDouble(const str: AnsiString): double;
var
value: real;
begin
if (str = '+Infinity') or (str = 'Infinity') then begin
result := DOUBLE_POSITIVE_INFINITY;
exit;
end;
if str = '-Infinity' then begin
result := DOUBLE_NEGATIVE_INFINITY;
exit;
end;
if str = 'NaN' then begin
result := DOUBLE_NAN;
exit;
end;
value := parse(str);
if (value < -DOUBLE_MAX_VALUE) or (value > DOUBLE_MAX_VALUE) then begin
raise NumberFormatException.create('RealValueRepresenter.parse: ' + msgIllegalNumberFormat);
end;
result := realToDouble(value);
end;
function RealValueRepresenter.getOrderDigits(): int;
begin
result := orderDigits;
end;
function RealValueRepresenter.getSignificandDigits(): int;
begin
result := significandDigits;
end;
function RealValueRepresenter.toString(const value: real): AnsiString;
var
expform: boolean;
c: char;
i: int;
j: int;
len: int;
order: int;
orddig: int;
sigdig: int;
dotpos: int;
tmp: long;
intval: long;
lvalue: real;
minvalue: real;
buf: char_Array1d;
begin
if realIsNaN(value) then begin
result := 'NaN';
exit;
end;
if value = REAL_POSITIVE_INFINITY then begin
result := 'Infinity';
exit;
end;
if value = REAL_NEGATIVE_INFINITY then begin
result := '-Infinity';
exit;
end;
buf := stringToCharArray('00000000000000000000000000000000');
len := 0;
order := realExponent(value);
tmp := realSignificand(value);
if order < 0 then begin
buf[len] := '-';
inc(len);
lvalue := -value;
end else begin
lvalue := value;
end;
if (tmp <> 0) or (order <> +$0000) and (order <> -$8000) then begin
order := realToInt(realBuild($3ffd, $9a209a84fbcff798) { 3.01029995663981195214e-0001 } * log2(lvalue));
sigdig := self.significandDigits;
if sigdig < 6 then begin
minvalue := 1.0 / tab_04_00(sigdig);
end else begin
minvalue := 1.0 / tab_04_00(6);
end;
{ significandDigits }
{ limitValueWithoutExponent = 10 }
{ -significandDigits -6 }
{ minvalue = 10 , но не меньше 10 }
expform := self.orderRequired or (lvalue < minvalue) or (lvalue >= self.limitValueWithoutExponent);
if expform then begin
if lvalue < 1.0 then dec(order);
intval := round(pow10(lvalue, sigdig - order - 1));
if intval < self.minRepresentValue then begin
intval := intval * 10;
dec(order);
end;
if intval > self.maxRepresentValue then begin
intval := intval div 10;
inc(order);
end;
dotpos := len + 1;
end else
if lvalue < 1.0 then begin
{ minvalue ≤ lvalue < 1 }
intval := round(pow10(lvalue, sigdig - 1));
dotpos := len + 1;
end else
if lvalue < self.limitValueWithFractialPart then begin
{ significandDigits-1 }
{ 1 ≤ lvalue < 10 }
intval := round(pow10(lvalue, sigdig - order - 1));
if intval < self.minRepresentValue then begin
intval := intval * 10;
dec(order);
end;
if intval > self.maxRepresentValue then begin
intval := intval div 10;
inc(order);
end;
dotpos := len + order + 1;
end else begin
{ significandDigits-1 significandDigits }
{ 10 ≤ lvalue < 10 }
intval := round(lvalue);
tmp := self.maxRepresentValue;
if intval > tmp then intval := tmp;
dotpos := len + sigdig;
end;
buf[dotpos] := '.';
for i := len + sigdig - 1 downto len do begin
if i >= dotpos then begin
buf[i + 1] := char(int(intval mod 10) + int('0'));
end else begin
buf[i] := char(int(intval mod 10) + int('0'));
end;
intval := intval div 10;
end;
inc(len, sigdig + 2);
repeat
c := buf[len - 1];
if (c <> '0') and (c <> '.') then break;
dec(len);
if c = '.' 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] := '-';
order := -order;
end else begin
buf[len] := '+';
end;
inc(len);
orddig := self.orderDigits;
if (orddig = 1) and (order >= 10) then begin
inc(orddig);
end;
if (orddig = 2) and (order >= 100) then begin
inc(orddig);
end;
if (orddig = 3) and (order >= 1000) then begin
inc(orddig);
end;
j := len + orddig;
for i := j - 1 downto len do begin
buf[i] := char((order mod 10) + int('0'));
order := order div 10;
end;
len := j;
end;
end else begin
inc(len, 3);
buf[len - 2] := '.';
end;
result := AnsiString_create(buf, 0, len);
end;
function RealValueRepresenter.parse(const str: AnsiString): real;
const
ULIMIT = long($1999999999999999);
var
negative: boolean;
c: char;
i: int;
len: int;
frac: int;
order: int;
digit: int;
unsres: long;
begin
len := length(str);
if len <= 0 then begin
raise NumberFormatException.create('RealValueRepresenter.parse: ' + msgIllegalNumberFormat);
end;
negative := false;
i := 0;
frac := 0;
order := 0;
unsres := 0;
case str[1] of
'-': begin
negative := true;
inc(i);
end;
'+', #$20:
inc(i);
end;
if i >= len then begin
raise NumberFormatException.create('RealValueRepresenter.parse: ' + msgIllegalNumberFormat);
end;
c := str[i + 1];
if ((c < '0') or (c > '9')) and (c <> '.') then begin
raise NumberFormatException.create('RealValueRepresenter.parse: ' + msgIllegalNumberFormat);
end;
if c <> '.' then begin
unsres := int(c) - int('0');
inc(i);
while i < len do begin
c := str[i + 1];
if (c < '0') or (c > '9') then break;
digit := int(c) - int('0');
if (unsres >= 0) and (unsres < ULIMIT) or (unsres = ULIMIT) and (digit < 6) then begin
unsres := 10 * unsres + digit;
end else begin
dec(frac);
end;
inc(i);
end;
end;
if (i < len) and (str[i + 1] = '.') then begin
inc(i);
while i < len do begin
c := str[i + 1];
if (c < '0') or (c > '9') then break;
digit := int(c) - int('0');
if (unsres >= 0) and (unsres < ULIMIT) or (unsres = ULIMIT) and (digit < 6) then begin
unsres := 10 * unsres + digit;
inc(frac);
end;
inc(i);
end;
end;
if unsres <> 0 then begin
while (frac > 0) and (ulongRem(unsres, 10) = 0) do begin
unsres := ulongDiv(unsres, 10);
dec(frac);
end;
end;
if negative then begin
negative := false;
result := -ulongToReal(unsres);
end else begin
result := ulongToReal(unsres);
end;
if i < len then begin
c := str[i + 1];
if (c = 'E') or (c = 'e') then begin
inc(i);
if i >= len then begin
raise NumberFormatException.create('RealValueRepresenter.parse: ' + msgIllegalNumberFormat);
end;
case str[i + 1] of
'-': begin
negative := true;
inc(i);
end;
'+':
inc(i);
end;
if i >= len then begin
raise NumberFormatException.create('RealValueRepresenter.parse: ' + msgIllegalNumberFormat);
end;
repeat
c := str[i + 1];
if (c < '0') or (c > '9') then break;
order := order * 10 + int(c) - int('0');
if order > 9999 then begin
raise NumberFormatException.create('RealValueRepresenter.parse: ' + msgIllegalNumberFormat);
end;
inc(i);
until i >= len;
if negative then begin
order := -order;
end;
end;
end;
if i < len then begin
raise NumberFormatException.create('RealValueRepresenter.parse: ' + msgIllegalNumberFormat);
end;
dec(order, frac);
while order >= 4932 do begin
result := pow10(result, 4932);
dec(order, 4932);
end;
while order <= -4931 do begin
result := pow10(result, -4931);
dec(order, -4931);
end;
result := pow10(result, order);
end;
{%endregion}
{%region Task }
constructor Task.create();
begin
inherited create();
self.scheduledTime := LONG_MIN_VALUE;
end;
destructor Task.destroy;
begin
system.enterCriticalSection(schedulerInstance.fSynchronize);
try
schedulerInstance.cancel(self);
finally
system.leaveCriticalSection(schedulerInstance.fSynchronize);
end;
inherited destroy;
end;
function Task.getScheduledTime(): long;
begin
result := scheduledTime;
end;
procedure Task.cancel();
var
succes: boolean;
begin
system.enterCriticalSection(schedulerInstance.fSynchronize);
try
succes := schedulerInstance.cancel(self);
finally
system.leaveCriticalSection(schedulerInstance.fSynchronize);
end;
if succes then Thread.queue(nil, @self.cancelled);
end;
procedure Task.schedule(delay: int);
begin
if delay <= 0 then begin
raise IllegalArgumentException.create('Task.schedule: ' + msgIllegalArgument + 'delay');
end;
system.enterCriticalSection(schedulerInstance.fSynchronize);
try
if schedulerInstance.indexOf(self) < 0 then begin
self.periodic := false;
self.runningTime := long(Thread.getTickCount64()) + long(delay);
schedulerInstance.push(self);
end;
finally
system.leaveCriticalSection(schedulerInstance.fSynchronize);
end;
end;
procedure Task.schedule(delay, period: int);
begin
if delay <= 0 then begin
raise IllegalArgumentException.create('Task.schedule: ' + msgIllegalArgument + 'delay');
end;
if period <= 0 then begin
raise IllegalArgumentException.create('Task.schedule: ' + msgIllegalArgument + 'period');
end;
system.enterCriticalSection(schedulerInstance.fSynchronize);
try
if schedulerInstance.indexOf(self) < 0 then begin
self.periodic := true;
self.period := period;
self.runningTime := long(Thread.getTickCount64()) + long(delay);
schedulerInstance.push(self);
end;
finally
system.leaveCriticalSection(schedulerInstance.fSynchronize);
end;
end;
procedure Task.cancelled();
begin
end;
{%endregion}
{%region Thread }
class function Thread.nextThreadNumber(): int;
begin
result := interlockedIncrement(@threadNumber);
end;
constructor Thread.create();
begin
create(nil, '');
end;
constructor Thread.create(const name: AnsiString);
begin
create(nil, name);
end;
constructor Thread.create(target: Runnable);
begin
create(target, '');
end;
constructor Thread.create(target: Runnable; const name: AnsiString);
var
thrdName: AnsiString;
begin
inherited create(true);
freeOnTerminate := true;
if length(name) = 0 then begin
thrdName := 'Thread ' + intToString(nextThreadNumber());
end else begin
thrdName := name;
end;
self.fTarget := target;
self.fName := thrdName;
end;
function Thread.toString(): AnsiString;
begin
result := 'thread ' + fName;
end;
function Thread.queryInterface({$IFDEF FPC_HAS_CONSTREF} constref {$ELSE} const {$ENDIF} iid: TGuid; out obj): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF};
begin
if getInterface(iid, obj) then begin
result := S_OK;
end else begin
result := E_NOINTERFACE;
end;
end;
function Thread._addref(): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF};
begin
result := -1;
end;
function Thread._release(): int; {$IFNDEF WINDOWS} cdecl {$ELSE} stdcall {$ENDIF};
begin
result := -1;
end;
function Thread.getName(): AnsiString;
begin
result := fName;
end;
procedure Thread.run();
begin
end;
procedure Thread.execute();
var
lTarget: Runnable;
begin
fxcontextLoadFrom(@defaultContext);
lTarget := self.fTarget;
if lTarget <> nil then begin
lTarget.run();
exit;
end;
run();
end;
{%endregion}
{%region Monitor.ThreadEntry }
constructor Monitor.ThreadEntry.create(owner: Monitor; monitorThread: TThread; state: int);
begin
inherited create();
self.fState := state;
self.fEntryCount := 1;
self.fMonitorEvent := rtlEventCreate();
self.fMonitorThread := monitorThread;
self.fOwner := owner;
end;
destructor Monitor.ThreadEntry.destroy;
begin
rtlEventDestroy(fMonitorEvent);
fSuspendTask.free();
inherited destroy;
end;
procedure Monitor.ThreadEntry.suspend();
var
event: PRTLEvent;
begin
event := fMonitorEvent;
repeat
rtlEventWaitFor(event);
until fState = RUNNING;
end;
procedure Monitor.ThreadEntry.resume();
begin
fState := RUNNING;
rtlEventSetEvent(fMonitorEvent);
end;
{%endregion}
{%region Monitor.SuspendTask }
constructor Monitor.SuspendTask.create(owner: Monitor; entry: ThreadEntry);
begin
inherited create();
self.fEntry := entry;
self.fOwner := owner;
end;
procedure Monitor.SuspendTask.run();
var
lOwner: Monitor;
lEntry: ThreadEntry;
begin
lOwner := self.fOwner;
lEntry := self.fEntry;
system.enterCriticalSection(lOwner.fMonitorSynchronize);
try
lEntry.fState := SUSPENDED;
lEntry.fSuspendTask := nil;
if lOwner.fOwningEntry = nil then begin
lOwner.pop();
end;
finally
system.leaveCriticalSection(lOwner.fMonitorSynchronize);
end;
free();
end;
{%endregion}
{%region Monitor }
procedure Monitor.afterConstruction();
begin
self.fWaitingEntries := ThreadEntry_Array1d(TObject_Array1d_create(7));
system.initCriticalSection(self.fMonitorSynchronize);
end;
procedure Monitor.beforeDestruction();
var
needRaise: boolean;
begin
system.enterCriticalSection(fMonitorSynchronize);
try
needRaise := (fWaitingCount > 0) or (fOwningEntry <> nil);
finally
system.leaveCriticalSection(fMonitorSynchronize);
end;
if needRaise then begin
raise IllegalMonitorStateException.create(msgIllegalMonitorState);
end;
system.doneCriticalSection(fMonitorSynchronize);
end;
procedure Monitor.notify();
label
label0;
var
needRaise: boolean;
i: int;
currentEntry: ThreadEntry;
lOwningEntry: ThreadEntry;
lWaitingEntries: ThreadEntry_Array1d;
begin
if self = nil then begin
raise NullPointerException.create(msgNullPointer);
end;
needRaise := false;
system.enterCriticalSection(fMonitorSynchronize);
try
lOwningEntry := self.fOwningEntry;
if (lOwningEntry = nil) or (lOwningEntry.fMonitorThread <> Thread.currentThread) then begin
needRaise := true;
end else begin
lWaitingEntries := self.fWaitingEntries;
for i := 0 to fWaitingCount - 1 do begin
currentEntry := lWaitingEntries[i];
if currentEntry.fState <> WAITING then continue;
currentEntry.fState := SUSPENDED;
currentEntry.fSuspendTask.free();
currentEntry.fSuspendTask := nil;
goto label0;
end;
inc(fNotifiesCount);
end;
label0:
finally
system.leaveCriticalSection(fMonitorSynchronize);
end;
if needRaise then begin
raise IllegalMonitorStateException.create('Monitor.notify: ' + msgIllegalMonitorState);
end;
end;
procedure Monitor.notifyAll();
var
needRaise: boolean;
notifying: boolean;
i: int;
currentEntry: ThreadEntry;
lOwningEntry: ThreadEntry;
lWaitingEntries: ThreadEntry_Array1d;
begin
if self = nil then begin
raise NullPointerException.create(msgNullPointer);
end;
needRaise := false;
system.enterCriticalSection(fMonitorSynchronize);
try
lOwningEntry := self.fOwningEntry;
if (lOwningEntry = nil) or (lOwningEntry.fMonitorThread <> Thread.currentThread) then begin
needRaise := true;
end else begin
notifying := false;
lWaitingEntries := self.fWaitingEntries;
for i := 0 to fWaitingCount - 1 do begin
currentEntry := lWaitingEntries[i];
if currentEntry.fState <> WAITING then continue;
currentEntry.fState := SUSPENDED;
currentEntry.fSuspendTask.free();
currentEntry.fSuspendTask := nil;
notifying := true;
end;
if not notifying then begin
inc(fNotifiesCount);
end;
end;
finally
system.leaveCriticalSection(fMonitorSynchronize);
end;
if needRaise then begin
raise IllegalMonitorStateException.create('Monitor.notifyAll: ' + msgIllegalMonitorState);
end;
end;
procedure Monitor.wait(millis: int);
var
needRaise: boolean;
needSuspend: boolean;
lNotifiesCount: long;
lOwningEntry: ThreadEntry;
lSuspendTask: Task;
begin
if self = nil then begin
raise NullPointerException.create(msgNullPointer);
end;
needRaise := false;
needSuspend := false;
system.enterCriticalSection(fMonitorSynchronize);
try
lOwningEntry := self.fOwningEntry;
lNotifiesCount := self.fNotifiesCount;
if (lOwningEntry = nil) or (lOwningEntry.fMonitorThread <> Thread.currentThread) then begin
needRaise := true;
end else
if lNotifiesCount <> 0 then begin
self.fNotifiesCount := lNotifiesCount - 1;
end else begin
needSuspend := true;
if millis > 0 then begin
lSuspendTask := SuspendTask.create(self, lOwningEntry);
lSuspendTask.schedule(millis);
lOwningEntry.fSuspendTask := lSuspendTask;
end;
lOwningEntry.fState := WAITING;
self.fOwningEntry := nil;
pop();
push(lOwningEntry);
end;
finally
system.leaveCriticalSection(fMonitorSynchronize);
end;
if needRaise then begin
raise IllegalMonitorStateException.create('Monitor.wait: ' + msgIllegalMonitorState);
end;
if needSuspend then begin
lOwningEntry.suspend();
end;
end;
procedure Monitor.push(entry: ThreadEntry);
var
count: int;
entries: ThreadEntry_Array1d;
newentries: ThreadEntry_Array1d;
begin
count := fWaitingCount;
entries := fWaitingEntries;
if count = length(entries) then begin
newentries := ThreadEntry_Array1d(TObject_Array1d_create((count shl 1) + 1));
arraycopyObjects(entries, 0, newentries, 0, count);
fWaitingEntries := newentries;
entries := newentries;
end;
entries[count] := entry;
fWaitingCount := count + 1;
end;
procedure Monitor.pop();
label
label0;
var
i: int;
index: int;
count: int;
lOwningEntry: ThreadEntry;
lWaitingEntries: ThreadEntry_Array1d;
begin
index := -1;
count := self.fWaitingCount;
lWaitingEntries := self.fWaitingEntries;
begin
for i := 0 to count - 1 do begin
if lWaitingEntries[i].fState = SUSPENDED then begin
index := i;
goto label0;
end;
end;
exit;
end;
label0:
lOwningEntry := lWaitingEntries[index];
if index < count - 1 then begin
arraycopyObjects(lWaitingEntries, index + 1, lWaitingEntries, index, count - index - 1);
end;
dec(count);
lWaitingEntries[count] := nil;
self.fWaitingCount := count;
self.fOwningEntry := lOwningEntry;
lOwningEntry.resume();
end;
{%endregion}
{%region Throwable }
constructor Throwable.create(const message: AnsiString; helpContext: int);
begin
inherited create();
self.fMessage := message;
self.fHelpContext := helpContext;
end;
function Throwable.toString(): AnsiString;
var
lMessage: AnsiString;
begin
lMessage := self.fMessage;
if length(lMessage) > 0 then begin
result := getClass().getCanonicalName() + ': ' + lMessage;
end else begin
result := getClass().getCanonicalName();
end;
end;
procedure Throwable.printStackTrace();
begin
if isConsole then begin
writeln(toString() + LINE_ENDING);
end;
end;
{%endregion}
{%region MemoryError }
procedure MemoryError.freeInstance();
begin
if not disallowFree then begin
inherited freeInstance();
end;
end;
{%endregion}
{%region Scheduler }
constructor Scheduler.create();
begin
inherited create();
self.fQueue := Task_Array1d(TObject_Array1d_create($1f));
self.fTimer := THandle(-1);
system.initCriticalSection(self.fSynchronize);
end;
destructor Scheduler.destroy;
begin
system.doneCriticalSection(fSynchronize);
freeTimer();
inherited destroy;
end;
function Scheduler.indexOf(t: Task): int;
begin
result := arrayfindeqfObject(fQueue, 0, fCount, t);
end;
function Scheduler.cancel(t: Task): boolean;
var
index: int;
lCount: int;
lQueue: Task_Array1d;
begin
index := indexOf(t);
if index < 0 then begin
result := false;
exit;
end;
lCount := self.fCount;
lQueue := self.fQueue;
if index < lCount - 1 then begin
arraycopyObjects(lQueue, index + 1, lQueue, index, lCount - index - 1);
end;
dec(lCount);
self.fCount := lCount;
lQueue[lCount] := nil;
if index = lCount then updateTimer();
result := true;
end;
function Scheduler.pop(): Task;
var
remainingTime: long;
lCount: int;
lQueue: Task_Array1d;
begin
lCount := self.fCount;
lQueue := self.fQueue;
if lCount <= 0 then begin
result := nil;
exit;
end;
dec(lCount);
result := lQueue[lCount];
remainingTime := result.runningTime - long(Thread.getTickCount64());
if remainingTime > 0 then begin
freeTimer();
fTimer := widgetSet.createTimer(int(remainingTime), @self.run);
result := nil;
exit;
end;
self.fCount := lCount;
lQueue[lCount] := nil;
updateTimer();
end;
procedure Scheduler.push(t: Task);
var
runningTime: long;
i: int;
index: int;
lCount: int;
lQueue: Task_Array1d;
newQueue: Task_Array1d;
begin
lCount := self.fCount;
lQueue := self.fQueue;
if lCount = length(lQueue) then begin
newQueue := Task_Array1d(TObject_Array1d_create((lCount shl 1) + 1));
arraycopyObjects(lQueue, 0, newQueue, 0, lCount);
self.fQueue := newQueue;
lQueue := newQueue;
end;
runningTime := t.runningTime;
index := lCount;
i := 0;
while i < index do begin
if lQueue[i].runningTime <= runningTime then begin
index := i;
arraycopyObjects(lQueue, index, lQueue, index + 1, lCount - index);
break;
end;
inc(i);
end;
inc(lCount);
self.fCount := lCount;
lQueue[index] := t;
if index = lCount - 1 then updateTimer();
end;
procedure Scheduler.updateTimer();
var
remainingTime: long;
lCount: int;
begin
freeTimer();
lCount := self.fCount;
if lCount <= 0 then exit;
remainingTime := fQueue[lCount - 1].runningTime - long(Thread.getTickCount64());
if remainingTime <= 0 then remainingTime := 1;
fTimer := widgetSet.createTimer(int(remainingTime), @self.run);
end;
procedure Scheduler.freeTimer();
var
lTimer: THandle;
begin
lTimer := self.fTimer;
if lTimer <> THandle(-1) then begin
widgetSet.destroyTimer(lTimer);
self.fTimer := THandle(-1);
end;
end;
procedure Scheduler.run();
var
tsk: Task;
begin
system.enterCriticalSection(fSynchronize);
try
tsk := pop();
if tsk <> nil then begin
tsk.scheduledTime := tsk.runningTime;
if tsk.periodic then begin
tsk.runningTime := long(Thread.getTickCount64()) + long(tsk.period);
push(tsk);
end;
end;
finally
system.leaveCriticalSection(fSynchronize);
end;
if tsk <> nil then tsk.run();
end;
{%endregion}
{%region Information }
function Information.isPrimitive(): boolean;
begin
result := false;
end;
function Information.isInstance(ref: TObject): boolean;
begin
result := not isPrimitive() and (ref <> nil) and isAssignableFrom(ref.getClass());
end;
function Information.isAssignableFrom(cls: _Class): boolean;
var
info: Information;
begin
if cls = nil then begin
raise NullPointerException.create('_Class.isAssignableFrom: ' + msgNullPointerArgument + 'cls');
end;
if not(cls is Information) then begin
raise IllegalArgumentException.create('_Class.isAssignableFrom: ' + msgIllegalArgument + 'cls');
end;
info := cls as Information;
if isPrimitive() then begin
result := info.getPrimitiveType() = self.getPrimitiveType();
exit;
end;
if isInterface() then begin
result := info.isInterfaceImplements(self);
exit;
end;
result := info.isInheritedFrom(self);
end;
function Information.getPrimitiveType(): int;
begin
result := -1;
end;
function Information.getProperty(const name: AnsiString): _Property;
begin
result := nil;
end;
function Information.getSuperclass(): _Class;
begin
result := nil;
end;
function Information.getInterfaces(): _Class_Array1d;
begin
result := nil;
end;
function Information.getProperties(): _Property_Array1d;
begin
result := nil;
end;
function Information.getUnitName(): AnsiString;
begin
result := '';
end;
function Information.createInstance(): DynamicalyAllocatedObject;
begin
raise UnsupportedOperationException.create('_Class.createInstance: ' + msgUnsupportedOperation);
end;
function Information.isInheritedFrom(const cls: Information): boolean;
begin
result := false;
end;
function Information.isInterfaceImplements(const cls: Information): boolean;
begin
result := false;
end;
{%endregion}
{%region PrimitiveInformation }
constructor PrimitiveInformation.create(info: int; const name: AnsiString);
var
lCustom: boolean;
lName: AnsiString;
begin
inherited create();
lCustom := false;
case info of
TYPE_BOOLEAN:
lName := 'boolean';
TYPE_CHAR:
lName := 'char';
TYPE_WCHAR:
lName := 'wchar';
TYPE_BYTE:
lName := 'byte';
TYPE_SHORT:
lName := 'short';
TYPE_INT:
lName := 'int';
TYPE_LONG:
lName := 'long';
TYPE_FLOAT:
lName := 'float';
TYPE_DOUBLE:
lName := 'double';
TYPE_UBYTE:
lName := 'ubyte';
TYPE_USHORT:
lName := 'ushort';
TYPE_UINT:
lName := 'uint';
TYPE_ULONG:
lName := 'ulong';
TYPE_ANSISTRING:
lName := 'AnsiString';
TYPE_UNICODESTRING:
lName := 'UnicodeString';
else
lName := name;
lCustom := true;
end;
self.custom := lCustom;
self.info := info;
self.name := lName;
end;
function PrimitiveInformation.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is PrimitiveInformation) and (PrimitiveInformation(anot).info = info);
end;
function PrimitiveInformation.getHashCode(): long;
begin
result := info;
end;
function PrimitiveInformation.toString(): AnsiString;
begin
if custom then begin
result := 'type ' + name;
exit;
end;
result := name;
end;
function PrimitiveInformation.isPrimitive(): boolean;
begin
result := true;
end;
function PrimitiveInformation.isInterface(): boolean;
begin
result := false;
end;
function PrimitiveInformation.getPrimitiveType(): int;
begin
result := info;
end;
function PrimitiveInformation.getCanonicalName(): AnsiString;
begin
result := name;
end;
function PrimitiveInformation.getSimpleName(): AnsiString;
begin
result := name;
end;
{%endregion}
{%region GuidInformation }
constructor GuidInformation.create(const info: TGuid);
begin
inherited create();
self.info := info;
end;
function GuidInformation.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is GuidInformation) and isEqualGuid(GuidInformation(anot).info, info);
end;
function GuidInformation.getHashCode(): long;
var
value: long2;
begin
value := long2(info);
result := value[0] xor value[1];
end;
function GuidInformation.toString(): AnsiString;
begin
result := 'interface ' + guidToString(info);
end;
function GuidInformation.isInterface(): boolean;
begin
result := true;
end;
function GuidInformation.getCanonicalName(): AnsiString;
begin
result := guidToString(info);
end;
function GuidInformation.getSimpleName(): AnsiString;
begin
result := guidToString(info);
end;
{%endregion}
{%region ClassInformation }
class function ClassInformation.typeInfoToLangType(tinfo: PTypeInfo): int;
label
label0;
var
tdata: PTypeData;
tkind: TTypeKind;
begin
tdata := getTypeData(tinfo);
tkind := tinfo^.kind;
begin
if tkind = tkInteger then begin
case tdata^.ordType of
otSByte:
result := TYPE_BYTE;
otSWord:
result := TYPE_SHORT;
otUByte:
result := TYPE_UBYTE;
otUWord:
result := TYPE_USHORT;
otULong:
result := TYPE_UINT;
else
goto label0;
end;
exit;
end;
if (tkind = tkFloat) and (tdata^.floatType = ftDouble) then begin
result := TYPE_DOUBLE;
exit;
end;
if tkind = tkInterfaceRaw then begin
result := TYPE_INTERFACE;
exit;
end;
end;
label0:
result := int(tkind);
end;
class function ClassInformation.propInfoToProperty(pinfo: PPropInfo): _Property;
var
tm: int;
r: boolean;
w: boolean;
s: boolean;
t: _Class;
n: AnsiString;
begin
tm := pinfo^.propProcs;
r := ((tm and $03) = TM_CONST) or (pinfo^.getProc <> nil);
w := pinfo^.setProc <> nil;
s := (((tm shr 4) and $03) = TM_CONST) or (pinfo^.storedProc <> nil);
t := classForType(Pointer(pinfo^.propType));
n := pinfo^.name;
result := PropertyInformation.create(r, w, s, t, n);
end;
constructor ClassInformation.create(info: TClass);
begin
inherited create();
self.info := info;
end;
function ClassInformation.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is ClassInformation) and (ClassInformation(anot).info = info);
end;
function ClassInformation.getHashCode(): long;
begin
result := long((@info)^);
end;
function ClassInformation.toString(): AnsiString;
var
cls: TClass;
begin
cls := info;
result := 'class ' + cls.unitName() + '.' + cls.className();
end;
function ClassInformation.isInterface(): boolean;
begin
result := false;
end;
function ClassInformation.getProperty(const name: AnsiString): _Property;
var
pinfo: PPropInfo;
begin
pinfo := info.getPropertyInfo(name);
if pinfo = nil then begin
result := nil;
exit;
end;
result := propInfoToProperty(pinfo);
end;
function ClassInformation.getSuperclass(): _Class;
var
parent: TClass;
begin
parent := info.classParent();
if parent = nil then begin
result := nil;
exit;
end;
result := ClassInformation.create(parent);
end;
function ClassInformation.getInterfaces(): _Class_Array1d;
var
i: int;
len: int;
gid: TGuid;
pgid: PGuid;
psid: PShortString;
table: PInterfaceTable;
begin
table := info.getInterfaceTable();
if table = nil then begin
result := nil;
exit;
end;
with table^ do begin
len := int(entryCount);
result := _Class_Array1d(IUnknown_Array1d_create(len));
for i := len - 1 downto 0 do begin
with entries[i] do begin
pgid := iid;
psid := iidstr;
end;
if pgid <> nil then begin
result[i] := classForType(pgid^);
continue;
end;
if (psid <> nil) and tryStringToGuid(psid^, gid) then begin
result[i] := classForType(gid);
continue;
end;
result[i] := InterfaceInformation.create(PTypeInfo(typeInfo(IUnknown)));
end;
end;
end;
function ClassInformation.getProperties(): _Property_Array1d;
var
i: int;
count: int;
pinfo: PPropInfo;
tinfo: PTypeInfo;
tdata: PTypeData;
begin
tinfo := PTypeInfo(info.classInfo());
if tinfo = nil then begin
result := nil;
exit;
end;
tdata := getTypeData(tinfo);
pinfo := PPropInfo(Pointer(@(tdata^.unitName[1])) + int(tdata^.unitName[0]));
count := system.PUInt16(pinfo)^;
pinfo := Pointer(pinfo) + 2;
result := _Property_Array1d(IUnknown_Array1d_create(count));
for i := 0 to count - 1 do begin
result[i] := propInfoToProperty(pinfo);
pinfo := PPropInfo(Pointer(@(pinfo^.name[1])) + int(pinfo^.name[0]));
end;
end;
function ClassInformation.getCanonicalName(): AnsiString;
var
c: TClass;
begin
c := info;
result := c.unitName() + '.' + c.className();
end;
function ClassInformation.getSimpleName(): AnsiString;
begin
result := info.className();
end;
function ClassInformation.getUnitName(): AnsiString;
begin
result := info.unitName();
end;
function ClassInformation.createInstance(): DynamicalyAllocatedObject;
type
DynamicalyAllocatedObjectClass = class of DynamicalyAllocatedObject;
var
c: TClass;
begin
c := info;
if not c.inheritsFrom(DynamicalyAllocatedObject) then begin
raise UnsupportedOperationException.create('_Class.createInstance: ' + msgUnsupportedOperation);
end;
result := DynamicalyAllocatedObjectClass(c).create();
end;
function ClassInformation.isInheritedFrom(const cls: Information): boolean;
var
c: TClass;
cid: TClass;
begin
if not(cls is ClassInformation) then begin
result := false;
exit;
end;
cid := ClassInformation(cls).info;
c := self.info;
repeat
if cid = c then begin
result := true;
exit;
end;
c := c.classParent();
until c = nil;
result := false;
end;
function ClassInformation.isInterfaceImplements(const cls: Information): boolean;
var
i: int;
c: TClass;
iid: TGuid;
gid: TGuid;
pgid: PGuid;
psid: PShortString;
table: PInterfaceTable;
begin
if cls is InterfaceInformation then begin
iid := getTypeData(InterfaceInformation(cls).info)^.iid;
end else
if cls is GuidInformation then begin
iid := GuidInformation(cls).info;
end else begin
result := false;
exit;
end;
c := self.info;
repeat
table := c.getInterfaceTable();
if table <> nil then begin
with table^ do begin
for i := int(entryCount) - 1 downto 0 do begin
with entries[i] do begin
pgid := iid;
psid := iidstr;
end;
if (pgid <> nil) and isEqualGuid(pgid^, iid) or (psid <> nil) and tryStringToGuid(psid^, gid) and isEqualGUID(gid, iid) then begin
result := true;
exit;
end;
end;
end;
end;
c := c.classParent();
until c = nil;
result := false;
end;
{%endregion}
{%region InterfaceInformation }
constructor InterfaceInformation.create(info: PTypeInfo);
begin
inherited create();
self.info := info;
end;
function InterfaceInformation.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is InterfaceInformation) and (InterfaceInformation(anot).info = info);
end;
function InterfaceInformation.getHashCode(): long;
begin
result := long((@info)^);
end;
function InterfaceInformation.toString(): AnsiString;
var
cls: PTypeInfo;
begin
cls := info;
result := 'interface ' + getTypeData(cls)^.intfUnit + '.' + cls^.name;
end;
function InterfaceInformation.isInterface(): boolean;
begin
result := true;
end;
function InterfaceInformation.getSuperclass(): _Class;
var
parent: PTypeInfo;
begin
parent := getTypeData(info)^.intfParent;
if parent = nil then begin
result := nil;
exit;
end;
result := InterfaceInformation.create(parent);
end;
function InterfaceInformation.getInterfaces(): _Class_Array1d;
var
parent: _Class;
begin
parent := getSuperclass();
if parent = nil then begin
result := nil;
exit;
end;
result := _Class_Array1d(IUnknown_Array1d_create([ parent ]));
end;
function InterfaceInformation.getCanonicalName(): AnsiString;
var
c: PTypeInfo;
begin
c := info;
result := getTypeData(c)^.intfUnit + '.' + c^.name;
end;
function InterfaceInformation.getSimpleName(): AnsiString;
begin
result := info^.name;
end;
function InterfaceInformation.getUnitName(): AnsiString;
begin
result := getTypeData(info)^.intfUnit;
end;
function InterfaceInformation.isInheritedFrom(const cls: Information): boolean;
var
c: PTypeInfo;
d: PTypeData;
iid: TGuid;
begin
if cls is InterfaceInformation then begin
iid := getTypeData(InterfaceInformation(cls).info)^.iid;
end else
if cls is GuidInformation then begin
iid := GuidInformation(cls).info;
end else begin
result := false;
exit;
end;
c := self.info;
repeat
d := getTypeData(c);
if isEqualGuid(d^.iid, iid) then begin
result := true;
exit;
end;
c := d^.intfParent;
until c = nil;
result := false;
end;
function InterfaceInformation.isInterfaceImplements(const cls: Information): boolean;
begin
result := isInheritedFrom(cls);
end;
{%endregion}
{%region PropertyInformation }
constructor PropertyInformation.create(readable, writeable, storeable: boolean; &type: _Class; const name: AnsiString);
var
lFlags: int;
begin
inherited create();
lFlags := 0;
if readable then lFlags := lFlags or $01;
if writeable then lFlags := lFlags or $02;
if storeable then lFlags := lFlags or $04;
self.flags := lFlags;
self.&type := &type;
self.name := name;
end;
function PropertyInformation.isReadable(): boolean;
begin
result := (flags and $01) <> 0;
end;
function PropertyInformation.isWriteable(): boolean;
begin
result := (flags and $02) <> 0;
end;
function PropertyInformation.isStoreable(): boolean;
begin
result := (flags and $04) <> 0;
end;
function PropertyInformation.getType(): _Class;
begin
result := &type;
end;
function PropertyInformation.getName(): AnsiString;
begin
result := name;
end;
{%endregion}
{%region TypeEnumeration }
constructor TypeEnumeration.create(info: PTypeInfo);
begin
inherited create();
self.info := info;
end;
function TypeEnumeration.hasMoreElements(): boolean;
var
k: TTypeKind;
begin
k := info^.kind;
result := (k = tkClass) or (k = tkInterface) or (k = tkInterfaceRaw);
end;
function TypeEnumeration.nextElement(): _Class;
var
i: int;
len: int;
pstrg: Pointer;
tinfo: PTypeInfo;
tdata: PTypeData;
pprop: PPropInfo;
ppcnt: system.PUInt16;
begin
tinfo := info;
tdata := getTypeData(tinfo);
case tinfo^.kind of
tkClass: begin
if int(tdata^.unitName[0]) = 0 then begin
tdata := getTypeData(PTypeInfo(nextAlignedAfter(Pointer(tdata) + $18)));
end;
ppcnt := system.PUInt16(Pointer(@(tdata^.unitName[1])) + system.UInt8(tdata^.unitName[0]));
pprop := PPropInfo(Pointer(ppcnt) + 2);
len := ppcnt^;
for i := 0 to len - 1 do begin
pprop := PPropInfo(Pointer(@(pprop^.name[1])) + system.UInt8(pprop^.name[0]));
end;
info := PTypeInfo(nextAlignedAfter(pprop));
result := ClassInformation.create(tdata^.classType);
end;
tkInterface, tkInterfaceRaw: begin
pstrg := @(tdata^.intfUnit);
len := system.UInt8(pstrg^);
info := PTypeInfo(nextAlignedAfter(pstrg + len + system.UInt8((pstrg + len + 1)^) + 2));
result := InterfaceInformation.create(tinfo);
end;
else
result := nil;
end;
end;
{%endregion}
initialization
exceptionHandlerInitialize();
default8087CW := $037f;
defaultMXCSR := $1f80;
defaultContext.fcw := $037f;
defaultContext.mxcsr := $1f80;
{$IFNDEF LIBRARY}
fxcontextLoadFrom(@defaultContext);
{$ENDIF}
typeInfosData := PTypeInfo_Array1d(Pointer_Array1d_create(31));
primitivesData := _Class_Array1d(IUnknown_Array1d_create([
PrimitiveInformation.create(TYPE_BOOLEAN) as _Class,
PrimitiveInformation.create(TYPE_CHAR) as _Class,
PrimitiveInformation.create(TYPE_WCHAR) as _Class,
PrimitiveInformation.create(TYPE_BYTE) as _Class,
PrimitiveInformation.create(TYPE_SHORT) as _Class,
PrimitiveInformation.create(TYPE_INT) as _Class,
PrimitiveInformation.create(TYPE_LONG) as _Class,
PrimitiveInformation.create(TYPE_FLOAT) as _Class,
PrimitiveInformation.create(TYPE_DOUBLE) as _Class,
PrimitiveInformation.create(TYPE_UBYTE) as _Class,
PrimitiveInformation.create(TYPE_USHORT) as _Class,
PrimitiveInformation.create(TYPE_UINT) as _Class,
PrimitiveInformation.create(TYPE_ULONG) as _Class,
PrimitiveInformation.create(TYPE_ANSISTRING) as _Class,
PrimitiveInformation.create(TYPE_UNICODESTRING) as _Class
]));
realRepresenter := RealValueRepresenter.create(REAL_SIGNIFICAND_DIGITS, REAL_ORDER_DIGITS);
floatRepresenter := RealValueRepresenter.create(FLOAT_SIGNIFICAND_DIGITS, FLOAT_ORDER_DIGITS);
doubleRepresenter := RealValueRepresenter.create(DOUBLE_SIGNIFICAND_DIGITS, DOUBLE_ORDER_DIGITS);
schedulerInstance := Scheduler.create();
classInfoAdd([
typeInfo(TObject),
typeInfo(TInterfacedObject),
typeInfo(TAggregatedObject),
typeInfo(TContainedObject),
typeInfo(IUnknown),
typeInfo(IInvokable),
typeInfo(IDispatch),
typeInfo(_Interface),
typeInfo(_Property),
typeInfo(_Class),
typeInfo(Runnable),
typeInfo(Value),
typeInfo(ValueExtended)
]);
finalization
realRepresenter.free();
floatRepresenter.free();
doubleRepresenter.free();
schedulerInstance.free();
exceptionHandlerFinalize();
end.
