Embarcadero RAD Studio - [3347] :: Прикладное программирование

unit System;

interface

{$IF defined(CPUX86) and defined(ASSEMBLER)}
{$DEFINE X86ASMRTL}
{$ELSE}
{$DEFINE PUREPASCAL}
{$ENDIF}

const
S_OK = 0;
S_FALSE = $00000001;

vtInteger = 0;
vtBoolean = 1;
vtChar = 2;
vtExtended = 3;
vtString = 4;
vtPointer = 5;
vtPChar = 6;
vtObject = 7;
vtClass = 8;
vtWideChar = 9;
vtPWideChar = 10;
vtAnsiString = 11;
vtCurrency = 12;
vtVariant = 13;
vtInterface = 14;
vtWideString = 15;
vtInt64 = 16;
vtUnicodeString = 17;

type
THandle = NativeUInt;
HRESULT = type Longint;
HINST = THandle;
HMODULE = HINST;
PByte = ^Byte;

TDateTime = type Double;
PExtended = ^Extended;
PShortString = ^ShortString;
PCurrency = ^Currency;
PVariant = ^Variant;
PInt64 = ^Int64;

PVarRec = ^TVarRec;
TVarRec = record
case Integer of
0: (case Byte of
vtInteger: (VInteger: Integer);
vtBoolean: (VBoolean: Boolean);
vtChar: (VChar: AnsiChar);
vtExtended: (VExtended: PExtended);
vtString: (VString: PShortString);
vtPointer: (VPointer: Pointer);
vtPChar: (VPChar: PAnsiChar);
vtObject: (VObject: Pointer);
vtClass: (VClass: Pointer);
vtWideChar: (VWideChar: WideChar);
vtPWideChar: (VPWideChar: PWideChar);
vtAnsiString: (VAnsiString: Pointer);
vtCurrency: (VCurrency: PCurrency);
vtVariant: (VVariant: PVariant);
vtInterface: (VInterface: Pointer);
vtWideString: (VWideString: Pointer);
vtInt64: (VInt64: PInt64);
vtUnicodeString: (VUnicodeString: Pointer);
);
1: (_Reserved1: NativeInt;
VType: Byte;
);
end;

TGUID = record
D1: Cardinal;
D2: Word;
D3: Word;
D4: array [0..7] of Byte;
end;

IInterface = interface
['{00000000-0000-0000-C000-000000000046}']
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
end;

IUnknown = IInterface;

TTypeKind = (tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString,
tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray, tkUString,
tkClassRef, tkPointer, tkProcedure);

var ExitCode: Integer = 0;

procedure _Halt0;
procedure _HandleFinally;
function _IntfClear(var Dest: IInterface): Pointer;
{$IF not defined(X86ASMRTL)}
function _FinalizeArray(P: Pointer; TypeInfo: Pointer; ElemCount: NativeUInt): Pointer;
{$ELSE}
procedure _FinalizeArray(P: Pointer; TypeInfo: Pointer; ElemCount: NativeUInt);
{$ENDIF}
{$IF defined(CPUX64)}
function _DelphiExceptionHandler(ExceptionRecord: Pointer; EstablisherFrame: NativeUInt; ContextRecord: Pointer; DispatcherContext: Pointer): LongInt; stdcall;
procedure _UnhandledException;
procedure _DestroyException(ExceptionPointers: Pointer; EstablisherFrame: NativeUInt);
{$ENDIF}

implementation

type
PPTypeInfo = ^PTypeInfo;
PTypeInfo = ^TTypeInfo;
TTypeInfo = packed record
Kind: TTypeKind;
Name: ShortString;
end;

TFieldInfo = packed record
TypeInfo: PPTypeInfo;
case Integer of
0: ( Offset: Cardinal );
1: ( _Dummy: NativeUInt );
end;

PFieldTable = ^TFieldTable;
TFieldTable = packed record
X: Word;
Size: Cardinal;
Count: Cardinal;
Fields: array [0..0] of TFieldInfo;
end;

procedure ExitProcess(ExitCode: LongWord); stdcall; external 'kernel32.dll' name 'ExitProcess';

procedure _Halt0;
begin
ExitProcess(ExitCode);
end;

procedure _HandleFinally;
asm
end;

function _IntfClear(var Dest: IInterface): Pointer;
{$IFDEF PUREPASCAL}
var
P: Pointer;
begin
Result := @Dest;
if Dest <> nil then
begin
P := Pointer(Dest);
Pointer(Dest) := nil;
IInterface(P)._Release;
end;
end;
{$ELSE !PUREPASCAL}
{$IFDEF CPUX86}
asm
MOV EDX,[EAX]
TEST EDX,EDX
JE @@1
MOV DWORD PTR [EAX],0
PUSH EAX
PUSH EDX
MOV EAX,[EDX]
CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release
POP EAX
@@1:
end;
{$ENDIF CPUX86}
{$ENDIF !PUREPASCAL}

{$IF not defined(X86ASMRTL)}
function _FinalizeArray(P: Pointer; TypeInfo: Pointer; ElemCount: NativeUInt): Pointer;
begin
Result := P;
if ElemCount = 0 then Exit;
case PTypeInfo(TypeInfo).Kind of
tkInterface:
while ElemCount > 0 do
begin
_IntfClear(IInterface(P^));
Inc(PByte(P), SizeOf(Pointer));
Dec(ElemCount);
end;
end;
end;
{$ELSE X86ASMRTL}
procedure _FinalizeArray(P: Pointer; TypeInfo: Pointer; ElemCount: NativeUInt);
asm
CMP ECX,0
JE @@zerolength
PUSH EAX
PUSH EBX
PUSH ESI
PUSH EDI
MOV EBX,EAX
MOV ESI,EDX
MOV EDI,ECX
XOR EDX,EDX
MOV AL,[ESI]
MOV DL,[ESI+1]
CMP AL,tkInterface
JE @@Interface
JMP @@exit
@@Interface:
MOV EAX,EBX
ADD EBX,4
CALL _IntfClear
DEC EDI
JG @@Interface
@@exit:
POP EDI
POP ESI
POP EBX
POP EAX
@@zerolength:
end;
{$ENDIF X86ASMRTL}

{$IF defined(CPUX64)}
function _DelphiExceptionHandler(ExceptionRecord: Pointer; EstablisherFrame: NativeUInt; ContextRecord: Pointer; DispatcherContext: Pointer): LongInt; stdcall;
begin
Result := 0;
end;

procedure _UnhandledException;
begin
end;

procedure _DestroyException(ExceptionPointers: Pointer; EstablisherFrame: NativeUInt);
begin
end;
{$ENDIF}

end.

Модерирует : ShIvADeSt
Версия для печати • Подписаться • Добавить в закладки
На первую страницу • к этому сообщению • к последнему сообщению