system.pas

delphi 不需任何控件

unit System;

interface
type
	TGUID=record
		D1: LongWord;
		D2, D3: Word;
		D4: array [0..7] of Byte;
	end;
	TInitContext = Integer;		//未用
	HResult = Integer;
	THandle = Cardinal;
	DWORD = Cardinal;
	
	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;
	
	IDispatch = interface(IUnknown)
	['{00020400-0000-0000-C000-000000000046}']
	function GetTypeInfoCount(out Count: Integer): HResult;stdcall;
	function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
	function GetIDsOfNames(const IID: TGUID; Names: Pointer;
		NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
	function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
		Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: 
		Pointer): HResult; stdcall;
	end;

procedure _InitExe;                             //EXE进入代码
procedure _HandleFinally;			//所有文件必要的，处理try...finally...end
procedure _Halt0;				//退出代码
procedure _InitLib;				//DLL进入代码
procedure _AbstractError;
function _IntfClear(var Dest:IUnknown):Pointer;	//接口自动析构
procedure _ObjSetup;				//原生类可以使用构造函数，可以使用New(f,Create)语法。占用0.5K代码空间。
procedure ExitProcess(uCode: LongWord);stdcall;external 'kernel32.dll';	//退出代码要调用的

//下面的内存管理我直接把C语言的拿来用了，以偷工减料。
function _GetMem(Size:Integer):Pointer;cdecl;external 'msvcrt.dll' name 'malloc';
function AllocMem(Size:Integer):Pointer;cdecl;external 'msvcrt.dll' name 'malloc';
function _ReAllocMem(Block:Pointer; Size:Integer):Pointer;cdecl;external 'msvcrt.dll' name 'realloc';
procedure _FreeMem(Block:Pointer);cdecl;external 'msvcrt.dll' name 'free';
procedure _CheckAutoResult(ResultCode:HResult);		//接口转换用的。

implementation

procedure _InitExe;asm end;
procedure _HandleFinally;asm end;
procedure _InitLib;asm end;
procedure _AbstractError;asm end;

//function _CheckAutoResult(ResultCode: HResult): HResult;
//asm 
//	MOV EAX,EAX 
//end;
procedure _CheckAutoResult(ResultCode:HResult);asm end;

procedure _Halt0; assembler;
asm
	push 0
	call ExitProcess
end;

function _IntfClear; assembler;
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;

const
    ovtInstanceSize = -8;   { Offset of instance size in OBJECTs    }
    ovtVmtPtrOffs   = -4;
procedure       _ObjSetup;
asm
{       FUNCTION _ObjSetup( self: ^OBJECT; vmt: ^VMT): ^OBJECT; }
{     ->EAX     Pointer to self (possibly nil)  }
{       EDX     Pointer to vmt  (possibly nil)  }
{     <-EAX     Pointer to self                 }
{       EDX     <> 0: an object was allocated   }
{       Z-Flag  Set: failure, Cleared: Success  }

        CMP     EDX,1   { is vmt = 0, indicating a call         }
        JAE     @@skip1 { from a constructor?                   }
        RET                     { return immediately with Z-flag cleared        }

@@skip1:
        PUSH    ECX
        TEST    EAX,EAX { is self already allocated?            }
        JNE     @@noAlloc
        MOV     EAX,[EDX].ovtInstanceSize
        TEST    EAX,EAX
        JE      @@zeroSize
        PUSH    EDX
        CALL    _GetMem
        POP     EDX
        TEST    EAX,EAX
        JZ      @@fail

        {       Zero fill the memory }
        PUSH    EDI
        MOV     ECX,[EDX].ovtInstanceSize
        MOV     EDI,EAX
        PUSH    EAX
        XOR     EAX,EAX
        SHR     ECX,2
        REP     STOSD
        MOV     ECX,[EDX].ovtInstanceSize
        AND     ECX,3
        REP     STOSB
        POP     EAX
        POP     EDI

        MOV     ECX,[EDX].ovtVmtPtrOffs
        TEST    ECX,ECX
        JL      @@skip
        MOV     [EAX+ECX],EDX   { store vmt in object at this offset    }
@@skip:
        TEST    EAX,EAX { clear zero flag                               }
        POP     ECX
        RET

@@fail:
        XOR     EDX,EDX
        POP     ECX
        RET

@@zeroSize:
        XOR     EDX,EDX
        CMP     EAX,1   { clear zero flag - we were successful (kind of) }
        POP     ECX
        RET

@@noAlloc:
        MOV     ECX,[EDX].ovtVmtPtrOffs
        TEST    ECX,ECX
        JL      @@exit
        MOV     [EAX+ECX],EDX   { store vmt in object at this offset    }
@@exit:
        XOR     EDX,EDX { clear allocated flag                  }
        TEST    EAX,EAX { clear zero flag                               }
        POP     ECX
end;

end.