D7的System.pas单元的实现部分
被我把所有实现代码都精简掉了。所有Linux代码更是毫不留情全部删除。先跟这些定义和函数混个脸熟。
感觉System单元主要用来处理字符、TObject、异常、线程、文件读写等等。
implementation
uses
SysInit;
{ This procedure should be at the very beginning of the }
{ text segment. It used to be used by _RunError to find }
{ start address of the text segment, but is not used anymore. }
procedure TextStart;
begin
end ;
function GetGOT: LongWord; export ;
{ $IFDEF PC_MAPPED_EXCEPTIONS }
const
UNWINDFI_TOPOFSTACK = $BE00EF00;
const
unwind = ' unwind.dll ' ;
type
UNWINDPROC = Pointer;
function UnwindRegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl ;
external unwind name ' __BorUnwind_RegisterIPLookup ' ;
function UnwindDelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl ;
external unwind name ' __BorUnwind_DelphiLookup ' ;
function UnwindRaiseException(Exc: Pointer): LongBool; cdecl ;
external unwind name ' __BorUnwind_RaiseException ' ;
function UnwindClosestHandler(Context: Pointer): LongWord; cdecl ;
external unwind name ' __BorUnwind_ClosestDelphiHandler ' ;
const { copied from xx.h }
cContinuable = 0 ;
cNonContinuable = 1 ;
cUnwinding = 2 ;
cUnwindingForExit = 4 ;
cUnwindInProgress = cUnwinding or cUnwindingForExit;
cDelphiException = $0EEDFADE;
cDelphiReRaise = $0EEDFADF;
cDelphiExcept = $0EEDFAE0;
cDelphiFinally = $0EEDFAE1;
cDelphiTerminate = $0EEDFAE2;
cDelphiUnhandled = $0EEDFAE3;
cNonDelphiException = $0EEDFAE4;
cDelphiExitFinally = $0EEDFAE5;
cCppException = $0EEFFACE; { used by BCB }
EXCEPTION_CONTINUE_SEARCH = 0 ;
EXCEPTION_EXECUTE_HANDLER = 1 ;
EXCEPTION_CONTINUE_EXECUTION = - 1 ;
{ $IFDEF PC_MAPPED_EXCEPTIONS }
const
excIsBeingHandled = $ 00000001 ;
excIsBeingReRaised = $ 00000002 ;
{ $ENDIF }
type
JmpInstruction =
packed record
opCode: Byte;
distance: Longint;
end ;
TExcDescEntry =
record
vTable: Pointer;
handler: Pointer;
end ;
PExcDesc = ^TExcDesc;
TExcDesc =
packed record
{ $IFNDEF PC_MAPPED_EXCEPTIONS }
jmp: JmpInstruction;
{ $ENDIF }
case Integer of
0 : (instructions: array [ 0 .. 0 ] of Byte);
1 { ... } : (cnt: Integer; excTab: array [ 0 .. 0 { cnt-1 } ] of TExcDescEntry);
end ;
{ $IFNDEF PC_MAPPED_EXCEPTIONS }
PExcFrame = ^TExcFrame;
TExcFrame = record
next: PExcFrame;
desc: PExcDesc;
hEBP: Pointer;
case Integer of
0 : ( );
1 : ( ConstructedObject: Pointer );
2 : ( SelfOfMethod: Pointer );
end ;
PExceptionRecord = ^TExceptionRecord;
TExceptionRecord =
record
ExceptionCode : LongWord;
ExceptionFlags : LongWord;
OuterException : PExceptionRecord;
ExceptionAddress : Pointer;
NumberParameters : Longint;
case { IsOsException: } Boolean of
True: (ExceptionInformation : array [ 0 .. 14 ] of Longint);
False: (ExceptAddr: Pointer; ExceptObject: Pointer);
end ;
{ $ENDIF }
{ $IFDEF PC_MAPPED_EXCEPTIONS }
const
UW_EXC_CLASS_BORLANDCPP = $FBEE0001;
UW_EXC_CLASS_BORLANDDELPHI = $FBEE0101;
type
// The following _Unwind_* types represent unwind.h
_Unwind_Word = LongWord;
_Unwind_Exception_Cleanup_Fn = Pointer;
_Unwind_Exception = packed record
exception_ class : _Unwind_Word;
exception_cleanup: _Unwind_Exception_Cleanup_Fn;
private _ 1 : _Unwind_Word;
private _ 2 : _Unwind_Word;
end ;
PRaisedException = ^TRaisedException;
TRaisedException = packed record
RefCount: Integer;
ExceptObject: TObject;
ExceptionAddr: Pointer;
HandlerEBP: LongWord;
Flags: LongWord;
Cleanup: Pointer;
Prev: PRaisedException;
ReleaseProc: Pointer;
end ;
{ $ELSE }
PRaiseFrame = ^TRaiseFrame;
TRaiseFrame = packed record
NextRaise: PRaiseFrame;
ExceptAddr: Pointer;
ExceptObject: TObject;
ExceptionRecord: PExceptionRecord;
end ;
{ $ENDIF }
const
cCR = $0D;
cLF = $0A;
cEOF = $1A;
{ $IFDEF MSWINDOWS }
type
PMemInfo = ^TMemInfo;
TMemInfo = packed record
BaseAddress: Pointer;
AllocationBase: Pointer;
AllocationProtect: Longint;
RegionSize: Longint;
State: Longint;
Protect: Longint;
Type_ 9 : Longint;
end ;
PStartupInfo = ^TStartupInfo;
TStartupInfo = record
cb: Longint;
lpReserved: Pointer;
lpDesktop: Pointer;
lpTitle: Pointer;
dwX: Longint;
dwY: Longint;
dwXSize: Longint;
dwYSize: Longint;
dwXCountChars: Longint;
dwYCountChars: Longint;
dwFillAttribute: Longint;
dwFlags: Longint;
wShowWindow: Word;
cbReserved2: Word;
lpReserved2: ^Byte;
hStdInput: Integer;
hStdOutput: Integer;
hStdError: Integer;
end ;
TWin32FindData = packed record
dwFileAttributes: Integer;
ftCreationTime: Int64;
ftLastAccessTime: Int64;
ftLastWriteTime: Int64;
nFileSizeHigh: Integer;
nFileSizeLow: Integer;
dwReserved0: Integer;
dwReserved1: Integer;
cFileName: array [ 0 .. 259 ] of Char;
cAlternateFileName: array [ 0 .. 13 ] of Char;
end ;
const
advapi32 = ' advapi32.dll ' ;
kernel = ' kernel32.dll ' ;
user = ' user32.dll ' ;
oleaut = ' oleaut32.dll ' ;
GENERIC_READ = Integer($ 80000000 );
GENERIC_WRITE = $ 40000000 ;
FILE_SHARE_READ = $ 00000001 ;
FILE_SHARE_WRITE = $ 00000002 ;
FILE_ATTRIBUTE_NORMAL = $ 00000080 ;
CREATE_NEW = 1 ;
CREATE_ALWAYS = 2 ;
OPEN_EXISTING = 3 ;
FILE_BEGIN = 0 ;
FILE_CURRENT = 1 ;
FILE_END = 2 ;
STD_INPUT_HANDLE = Integer(- 10 );
STD_OUTPUT_HANDLE = Integer(- 11 );
STD_ERROR_HANDLE = Integer(- 12 );
MAX_PATH = 260 ;
function CloseHandle(Handle: Integer): Integer; stdcall ; external kernel name ' CloseHandle ' ;
function CreateFileA(lpFileName: PChar; dwDesiredAccess, dwShareMode: Integer; lpSecurityAttributes: Pointer; dwCreationDisposition, dwFlagsAndAttributes: Integer; hTemplateFile: Integer): Integer; stdcall ; external kernel name ' CreateFileA ' ;
function DeleteFileA(Filename: PChar): LongBool; stdcall ; external kernel name ' DeleteFileA ' ;
function GetFileType(hFile: Integer): Integer; stdcall ; external kernel name ' GetFileType ' ;
procedure GetSystemTime; stdcall ; external kernel name ' GetSystemTime ' ;
function GetFileSize(Handle: Integer; x: Integer): Integer; stdcall ; external kernel name ' GetFileSize ' ;
function GetStdHandle(nStdHandle: Integer): Integer; stdcall ; external kernel name ' GetStdHandle ' ;
function MoveFileA(OldName, NewName: PChar): LongBool; stdcall ; external kernel name ' MoveFileA ' ;
procedure RaiseException; stdcall ; external kernel name ' RaiseException ' ;
function ReadFile(hFile: Integer; var Buffer; nNumberOfBytesToRead: Cardinal; var lpNumberOfBytesRead: Cardinal; lpOverlapped: Pointer): Integer; stdcall ; external kernel name ' ReadFile ' ;
procedure RtlUnwind; stdcall ; external kernel name ' RtlUnwind ' ;
function SetEndOfFile(Handle: Integer): LongBool; stdcall ; external kernel name ' SetEndOfFile ' ;
function SetFilePointer(Handle, Distance: Integer; DistanceHigh: Pointer; MoveMethod: Integer): Integer; stdcall ; external kernel name ' SetFilePointer ' ;
procedure UnhandledExceptionFilter; stdcall ; external kernel name ' UnhandledExceptionFilter ' ;
function WriteFile(hFile: Integer; const Buffer; nNumberOfBytesToWrite: Cardinal; var lpNumberOfBytesWritten: Cardinal; lpOverlapped: Pointer): Integer; stdcall ; external kernel name ' WriteFile ' ;
function CharNext(lpsz: PChar): PChar; stdcall ; external user name ' CharNextA ' ;
function CreateThread(SecurityAttributes: Pointer; StackSize: LongWord; ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord; var ThreadId: LongWord): Integer; stdcall ; external kernel name ' CreateThread ' ;
procedure ExitThread(ExitCode: Integer); stdcall ; external kernel name ' ExitThread ' ;
procedure ExitProcess(ExitCode: Integer); stdcall ; external kernel name ' ExitProcess ' ;
procedure MessageBox(Wnd: Integer; Text: PChar; Caption: PChar; Typ: Integer); stdcall ; external user name ' MessageBoxA ' ;
function CreateDirectory(PathName: PChar; Attr: Integer): WordBool; stdcall ; external kernel name ' CreateDirectoryA ' ;
function FindClose(FindFile: Integer): LongBool; stdcall ; external kernel name ' FindClose ' ;
function FindFirstFile(FileName: PChar; var FindFileData: TWIN32FindData): Integer; stdcall ; external kernel name ' FindFirstFileA ' ;
function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall ; external kernel name ' FreeLibrary ' ;
function GetCommandLine: PChar; stdcall ; external kernel name ' GetCommandLineA ' ;
function GetCurrentDirectory(BufSize: Integer; Buffer: PChar): Integer; stdcall ; external kernel name ' GetCurrentDirectoryA ' ;
function GetLastError: Integer; stdcall ; external kernel name ' GetLastError ' ;
procedure SetLastError(ErrorCode: Integer); stdcall ; external kernel name ' SetLastError ' ;
function GetLocaleInfo(Locale: Longint; LCType: Longint; lpLCData: PChar; cchData: Integer): Integer; stdcall ; external kernel name ' GetLocaleInfoA ' ;
function GetModuleFileName(Module: Integer; Filename: PChar; Size: Integer): Integer; stdcall ; external kernel name ' GetModuleFileNameA ' ;
function GetModuleHandle(ModuleName: PChar): Integer; stdcall ; external kernel name ' GetModuleHandleA ' ;
function GetProcAddress(Module: Integer; ProcName: PChar): Pointer; stdcall ; external kernel name ' GetProcAddress ' ;
procedure GetStartupInfo( var lpStartupInfo: TStartupInfo); stdcall ; external kernel name ' GetStartupInfoA ' ;
function GetThreadLocale: Longint; stdcall ; external kernel name ' GetThreadLocale ' ;
function LoadLibraryEx(LibName: PChar; hFile: Longint; Flags: Longint): Longint; stdcall ; external kernel name ' LoadLibraryExA ' ;
function LoadString(Instance: Longint; IDent: Integer; Buffer: PChar; Size: Integer): Integer; stdcall ; external user name ' LoadStringA ' ;
function lstrcat(lpString1, lpString2: PChar): PChar; stdcall ; external kernel name ' lstrcatA ' ;
function lstrcpy(lpString1, lpString2: PChar): PChar; stdcall ; external kernel name ' lstrcpyA ' ;
function lstrcpyn(lpString1, lpString2: PChar; iMaxLength: Integer): PChar; stdcall ; external kernel name ' lstrcpynA ' ;
function _strlen(lpString: PChar): Integer; stdcall ; external kernel name ' lstrlenA ' ;
function MultiByteToWideChar(CodePage, Flags: Integer; MBStr: PChar; MBCount: Integer; WCStr: PWideChar; WCCount: Integer): Integer; stdcall ; external kernel name ' MultiByteToWideChar ' ;
function RegCloseKey(hKey: Integer): Longint; stdcall ; external advapi32 name ' RegCloseKey ' ;
function RegOpenKeyEx(hKey: LongWord; lpSubKey: PChar; ulOptions, samDesired: LongWord; var phkResult: LongWord): Longint; stdcall ; external advapi32 name ' RegOpenKeyExA ' ;
function RegQueryValueEx(hKey: LongWord; lpValueName: PChar; lpReserved: Pointer; lpType: Pointer; lpData: PChar; lpcbData: Pointer): Integer; stdcall ; external advapi32 name ' RegQueryValueExA ' ;
function RemoveDirectory(PathName: PChar): WordBool; stdcall ; external kernel name ' RemoveDirectoryA ' ;
function SetCurrentDirectory(PathName: PChar): WordBool; stdcall ; external kernel name ' SetCurrentDirectoryA ' ;
function WideCharToMultiByte(CodePage, Flags: Integer; WCStr: PWideChar; WCCount: Integer; MBStr: PChar; MBCount: Integer; DefaultChar: PChar; UsedDefaultChar: Pointer): Integer; stdcall ; external kernel name ' WideCharToMultiByte ' ;
function VirtualQuery(lpAddress: Pointer; var lpBuffer: TMemInfo; dwLength: Longint): Longint; stdcall ; external kernel name ' VirtualQuery ' ;
function SysAllocString(P: PWideChar): PWideChar; stdcall ; external oleaut name ' SysAllocString ' ;
function SysAllocStringLen(P: PWideChar; Len: Integer): PWideChar; stdcall ; external oleaut name ' SysAllocStringLen ' ;
function SysReAllocStringLen( var S: WideString; P: PWideChar; Len: Integer): LongBool; stdcall ; external oleaut name ' SysReAllocStringLen ' ;
procedure SysFreeString( const S: WideString); stdcall ; external oleaut name ' SysFreeString ' ;
function SysStringLen( const S: WideString): Integer; stdcall ; external oleaut name ' SysStringLen ' ;
function InterlockedIncrement( var Addend: Integer): Integer; stdcall ; external kernel name ' InterlockedIncrement ' ;
function InterlockedDecrement( var Addend: Integer): Integer; stdcall ; external kernel name ' InterlockedDecrement ' ;
function GetCurrentThreadId: LongWord; stdcall ; external kernel name ' GetCurrentThreadId ' ;
function GetVersion: LongWord; stdcall ; external kernel name ' GetVersion ' ;
function QueryPerformanceCounter( var lpPerformanceCount: Int64): LongBool; stdcall external kernel name ' QueryPerformanceCounter ' ;
function GetTickCount: Cardinal; external kernel name ' GetTickCount ' ;
function GetCmdShow: Integer;
var
DefaultUserCodePage: Integer;
function WCharFromChar(WCharDest: PWideChar; DestChars: Integer; const CharSource: PChar; SrcBytes: Integer): Integer; forward ;
function CharFromWChar(CharDest: PChar; DestBytes: Integer; const WCharSource: PWideChar; SrcChars: Integer): Integer; forward ;
{ ----------------------------------------------------- }
{ Memory manager }
{ ----------------------------------------------------- }
{ $IFDEF MSWINDOWS }
{ $I GETMEM.INC }
{ $ENDIF }
var
MemoryManager: TMemoryManager = (
GetMem: SysGetMem;
FreeMem: SysFreeMem;
ReallocMem: SysReallocMem);
{ $IFDEF PC_MAPPED_EXCEPTIONS }
var
// Unwinder: TUnwinder = (
// RaiseException: UnwindRaiseException;
// RegisterIPLookup: UnwindRegisterIPLookup;
// UnregisterIPLookup: UnwindUnregisterIPLookup;
// DelphiLookup: UnwindDelphiLookup);
Unwinder: TUnwinder;
{ $IFDEF STATIC_UNWIND }
{ $IFDEF PIC }
{ $L 'objs/arith.pic.o' }
{ $L 'objs/diag.pic.o' }
{ $L 'objs/delphiuw.pic.o' }
{ $L 'objs/unwind.pic.o' }
{ $ELSE }
{ $L 'objs/arith.o' }
{ $L 'objs/diag.o' }
{ $L 'objs/delphiuw.o' }
{ $L 'objs/unwind.o' }
{ $ENDIF }
procedure Arith_RdUnsigned; external ;
procedure Arith_RdSigned; external ;
procedure __assert_fail; cdecl ; external libc name ' __assert_fail ' ;
procedure malloc; cdecl ; external libc name ' malloc ' ;
procedure memset; cdecl ; external libc name ' memset ' ;
procedure strchr; cdecl ; external libc name ' strchr ' ;
procedure strncpy; cdecl ; external libc name ' strncpy ' ;
procedure strcpy; cdecl ; external libc name ' strcpy ' ;
procedure strcmp; cdecl ; external libc name ' strcmp ' ;
procedure printf; cdecl ; external libc name ' printf ' ;
procedure free; cdecl ; external libc name ' free ' ;
procedure getenv; cdecl ; external libc name ' getenv ' ;
procedure strtok; cdecl ; external libc name ' strtok ' ;
procedure strdup; cdecl ; external libc name ' strdup ' ;
procedure __strdup; cdecl ; external libc name ' __strdup ' ;
procedure fopen; cdecl ; external libc name ' fopen ' ;
procedure fdopen; cdecl ; external libc name ' fdopen ' ;
procedure time; cdecl ; external libc name ' time ' ;
procedure ctime; cdecl ; external libc name ' ctime ' ;
procedure fclose; cdecl ; external libc name ' fclose ' ;
procedure fprintf; cdecl ; external libc name ' fprintf ' ;
procedure vfprintf; cdecl ; external libc name ' vfprintf ' ;
procedure fflush; cdecl ; external libc name ' fflush ' ;
procedure dup; cdecl ; external libc name ' dup ' ;
procedure debug_init; external ;
procedure debug_print; external ;
procedure debug_ class _enabled; external ;
procedure debug_ continue ; external ;
{ $ENDIF }
{ $ENDIF }
function _GetMem(Size: Integer): Pointer;
const
FreeMemorySignature = Longint($FBEEFBEE);
function _FreeMem(P: Pointer): Integer;
function _ReallocMem( var P: Pointer; NewSize: Integer): Pointer;
procedure GetMemoryManager( var MemMgr: TMemoryManager);
procedure SetMemoryManager( const MemMgr: TMemoryManager);
function IsMemoryManagerSet: Boolean;
procedure GetUnwinder( var Dest: TUnwinder);
procedure SetUnwinder( const NewUnwinder: TUnwinder);
function IsUnwinderSet: Boolean;
procedure InitUnwinder;
function SysClosestDelphiHandler(Context: Pointer): LongWord;
function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool;
procedure SysUnregisterIPLookup(StartAddr: LongInt);
function SysRaiseException(Exc: Pointer): LongBool; export ;
// SysRaiseCPPException
// Called to reraise a C++ exception that is unwinding through pascal code.
function SysRaiseCPPException(Exc: Pointer; priv2: Pointer; cls: LongWord): LongBool;
const
MAX_NESTED_EXCEPTIONS = 16 ;
{ $ENDIF }
threadvar
{ $IFDEF PC_MAPPED_EXCEPTIONS }
ExceptionObjects: array [ 0 ..MAX_NESTED_EXCEPTIONS- 1 ] of TRaisedException;
ExceptionObjectCount: Integer;
OSExceptionsBlocked: Integer;
ExceptionList: PRaisedException;
{ $ELSE }
RaiseListPtr: pointer;
{ $ENDIF }
InOutRes: Integer;
var
notimpl: array [ 0 .. 15 ] of Char = ' not implemented ' # 10 ;
procedure NotImplemented;
{ $IFDEF PC_MAPPED_EXCEPTIONS }
procedure BlockOSExceptions;
procedure UnblockOSExceptions;
// Access to a TLS variable. Note the comment in BeginThread before
// you change the implementation of this function .
function AreOSExceptionsBlocked: Boolean;
const
TRAISEDEXCEPTION_SIZE = SizeOf(TRaisedException);
function CurrentException: PRaisedException;
function CurrentPrivateException: PRaisedException;
{
In the interests of code size here, this function is slightly overloaded.
It is responsible for freeing up the current exception record on the
exception stack, and it conditionally returns the thrown object to the
caller. If the object has been acquired through AcquireExceptionObject,
we don't return the thrown object.
}
function FreeException: Pointer;
procedure ReleaseDelphiException;
function AllocateException(Exception: Pointer; ExceptionAddr: Pointer): PRaisedException;
function AcquireExceptionObject: Pointer;
procedure ReleaseExceptionObject;
function ExceptObject: TObject;
function ExceptAddr: Pointer;
function ExceptObject: TObject;
function ExceptAddr: Pointer;
function AcquireExceptionObject: Pointer;
procedure ReleaseExceptionObject;
function RaiseList: Pointer;
function SetRaiseList(NewPtr: Pointer): Pointer;
procedure _CVR_PROBE; external ' coverage.dll ' name ' __CVR_PROBE '
function _CVR_STMTPROBE; external ' coverage.dll ' name ' __CVR_STMTPROBE '
procedure RunErrorAt(ErrCode: Integer; ErrorAtAddr: Pointer);
procedure ErrorAt(ErrorCode: Byte; ErrorAddr: Pointer);
procedure Error(errorCode: TRuntimeError);
procedure __IOTest;
procedure SetInOutRes(NewValue: Integer);
procedure InOutError;
procedure ChDir( const S: string );
procedure ChDir(P: PChar);
procedure _Copy { s : ShortString; index, count : Integer ) : ShortString } ;
procedure _Delete { var s : openstring; index, count : Integer } ;
procedure _LGetDir(D: Byte; var S: string );
procedure _SGetDir(D: Byte; var S: ShortString);
procedure _Insert { source : ShortString; var s : openstring; index : Integer } ;
function IOResult: Integer;
procedure MkDir( const S: string );
procedure MkDir(P: PChar);
procedure Move( const Source; var Dest; count : Integer );
function GetParamStr(P: PChar; var Param: string ): PChar;
function ParamCount: Integer;
type
PCharArray = array [ 0 .. 0 ] of PChar;
function ParamStr(Index: Integer): string ;
procedure _Pos { substr : ShortString; s : ShortString ) : Integer } ;
// Don ' t use var param here - var ShortString is an open string param, which passes
// the ptr in EAX and the string ' s declared buffer length in EDX. Compiler codegen
// expects only two params for this call - ptr and newlength
procedure _SetLength(s: PShortString; newLength: Byte);
procedure _SetString(s: PShortString; buffer: PChar; len: Byte);
procedure Randomize;
procedure RmDir( const S: string );
procedure RmDir(P: PChar);
function UpCase( ch : Char ) : Char;
procedure Set8087CW(NewCW: Word);
function Get8087CW: Word;
procedure _COS;
procedure _EXP;
procedure _INT;
procedure _SIN;
procedure _FRAC;
procedure _ROUND;
procedure _TRUNC;
procedure _AbstractError;
function TextOpen( var t: TTextRec): Integer; forward ;
function OpenText( var t: TTextRec; Mode: Word): Integer;
function _ResetText( var t: TTextRec): Integer;
function _RewritText( var t: TTextRec): Integer;
function _Append( var t: TTextRec): Integer;
function TextIn( var t: TTextRec): Integer;
function FileNOPProc( var t): Integer;
function TextOut( var t: TTextRec): Integer;
function InternalClose(Handle: Integer): Boolean;
function TextClose( var t: TTextRec): Integer;
function TextOpenCleanup( var t: TTextRec): Integer;
function TextOpen( var t: TTextRec): Integer;
const
fNameLen = 260 ;
function _Assign( var t: TTextRec; const s: String): Integer;
function InternalFlush( var t: TTextRec; Func: TTextIOFunc): Integer;
function Flush( var t: Text): Integer;
function _Flush( var t: TTextRec): Integer;
type
TIOProc = function (hFile: Integer; Buffer: Pointer; nNumberOfBytesToWrite: Cardinal;
var lpNumberOfBytesWritten: Cardinal; lpOverlapped: Pointer): Integer; stdcall ;
function ReadFileX(hFile: Integer; Buffer: Pointer; nNumberOfBytesToRead: Cardinal; var lpNumberOfBytesRead: Cardinal; lpOverlapped: Pointer): Integer; stdcall ; external kernel name ' ReadFile ' ;
function WriteFileX(hFile: Integer; Buffer: Pointer; nNumberOfBytesToWrite: Cardinal; var lpNumberOfBytesWritten: Cardinal; lpOverlapped: Pointer): Integer; stdcall ; external kernel name ' WriteFile ' ;
function BlockIO( var f: TFileRec; buffer: Pointer; recCnt: Cardinal; var recsDone: Longint; ModeMask: Integer; IOProc: TIOProc; ErrorNo: Integer): Cardinal;
function _BlockRead( var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsRead: Longint): Longint;
function _BlockWrite( var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsWritten: Longint): Longint;
function _Close( var t: TTextRec): Integer;
procedure _PStrCat;
procedure _PStrNCat;
procedure _PStrCpy(Dest: PShortString; Source: PShortString);
procedure _PStrNCpy(Dest: PShortString; Source: PShortString; MaxLen: Byte);
procedure _PStrCmp;
procedure _AStrCmp;
function _EofFile( var f: TFileRec): Boolean;
function _EofText( var t: TTextRec): Boolean;
function _Eoln( var t: TTextRec): Boolean;
procedure _Erase( var f: TFileRec);
procedure _FSafeDivideR;
procedure _FSafeDivide;
function _FilePos( var f: TFileRec): Longint;
function _FileSize( var f: TFileRec): Longint;
procedure _FillChar( var Dest; count: Integer; Value: Char);
procedure Mark;
procedure _RandInt;
procedure _RandExt;
const two2neg32: double = (( 1.0 /$ 10000 ) / $ 10000 ); // 2 ^- 32
function _ReadRec( var f: TFileRec; Buffer: Pointer): Integer;
function TryOpenForInput( var t: TTextRec): Boolean;
function _ReadChar( var t: TTextRec): Char;
function _ReadLong( var t: TTextRec): Longint;
function ReadLine( var t: TTextRec; buf: Pointer; maxLen: Longint): Pointer;
procedure _ReadString( var t: TTextRec; s: PShortString; maxLen: Longint);
procedure _ReadCString( var t: TTextRec; s: PChar; maxLen: Longint);
procedure _ReadLString( var t: TTextRec; var s: AnsiString);
function IsValidMultibyteChar( const Src: PChar; SrcBytes: Integer): Boolean;
function _ReadWChar( var t: TTextRec): WideChar;
procedure _ReadWCString( var t: TTextRec; s: PWideChar; maxBytes: Longint);
procedure _ReadWString( var t: TTextRec; var s: WideString);
function _ReadExt( var t: TTextRec): Extended;
procedure _ReadLn( var t: TTextRec);
procedure _Rename( var f: TFileRec; newName: PChar);
procedure Release;
function _CloseFile( var f: TFileRec): Integer;
function OpenFile( var f: TFileRec; recSiz: Longint; mode: Longint): Integer;
function _ResetFile( var f: TFileRec; recSize: Longint): Integer;
function _RewritFile( var f: TFileRec; recSize: Longint): Integer;
procedure _Seek( var f: TFileRec; recNum: Cardinal);
function _SeekEof( var t: TTextRec): Boolean;
function _SeekEoln( var t: TTextRec): Boolean;
procedure _SetTextBuf( var t: TTextRec; p: Pointer; size: Longint);
procedure _StrLong(val, Longint; s: PShortString);
procedure _Str0Long(val: Longint; s: PShortString);
procedure _Truncate( var f: TFileRec);
function _ValLong( const s: String; var code: Integer): Longint;
function _WriteRec( var f: TFileRec; buffer: Pointer): Pointer;
// If the file is Output or ErrOutput std variable, try to open it
// Otherwise, runtime error.
function TryOpenForOutput( var t: TTextRec): Boolean;
function _WriteBytes( var t: TTextRec; const b; cnt : Longint): Pointer;
function _WriteSpaces( var t: TTextRec; cnt: Longint): Pointer;
function _Write0Char( var t: TTextRec; c: Char): Pointer;
function _WriteChar( var t: TTextRec; c: Char; Integer): Pointer;
function _WriteBool( var t: TTextRec; val: Boolean; Longint): Pointer;
function _Write0Bool( var t: TTextRec; val: Boolean): Pointer;
function _WriteLong( var t: TTextRec; val, Longint): Pointer;
function _Write0Long( var t: TTextRec; val: Longint): Pointer;
function _Write0String( var t: TTextRec; const s: ShortString): Pointer;
function _WriteString( var t: TTextRec; const s: ShortString; Longint): Pointer;
function _Write0CString( var t: TTextRec; s: PChar): Pointer;
function _WriteCString( var t: TTextRec; s: PChar; Longint): Pointer;
procedure _Write2Ext;
procedure _Write1Ext;
procedure _Write0Ext;
function _WriteLn( var t: TTextRec): Pointer;
procedure __CToPasStr(Dest: PShortString; const Source: PChar);
procedure __CLenToPasStr(Dest: PShortString; const Source: PChar; MaxLen: Integer);
procedure __ArrayToPasStr(Dest: PShortString; const Source: PChar; Len: Integer);
procedure __PasToCStr( const Source: PShortString; const Dest: PChar);
procedure _SetElem;
procedure _SetRange;
procedure _SetEq;
procedure _SetLe;
procedure _SetIntersect;
procedure _SetIntersect3;
procedure _SetUnion;
procedure _SetUnion3;
procedure _SetSub;
procedure _SetSub3;
procedure _SetExpand;
procedure _EmitDigits;
procedure _ScaleExt;
const
Ten: Double = 10.0 ;
NanStr: String[ 3 ] = ' Nan ' ;
PlusInfStr: String[ 4 ] = ' +Inf ' ;
MinInfStr: String[ 4 ] = ' -Inf ' ;
procedure _Str2Ext;//( val: Extended; width, precision: Longint; var s: String );
procedure _Str0Ext;
procedure _Str1Ext;//( val: Extended; Longint; var s: String );
function _ValExt( s: AnsiString; VAR code: Integer ) : Extended;
procedure _ValExt;
procedure FPower10;
function _Pow10(val: Extended; Power: Integer): Extended;
procedure _Pow10;
const
RealBias = 129 ;
ExtBias = $3FFF;
procedure _Real2Ext;// ( val : Real ) : Extended;
procedure _Ext2Real;// ( val : Extended ) : Real;
const
ovtInstanceSize = - 8 ; { Offset of instance size in OBJECTs }
ovtVmtPtrOffs = - 4 ;
procedure _ObjSetup;
procedure _ObjCopy;
procedure _Fail;
function GetKeyboardType(nTypeFlag: Integer): Integer; stdcall ; external user name ' GetKeyboardType ' ;
function _isNECWindows: Boolean;
const
HKEY_LOCAL_MACHINE = $ 80000002 ;
// workaround a Japanese Win95 bug
procedure _FpuMaskInit;
procedure _FpuInit;
procedure _BoundErr;
procedure _IntOver;
function TObject.ClassType: TClass;
class function TObject.ClassName: ShortString;
class function TObject.ClassNameIs( const Name: string ): Boolean;
class function TObject.ClassParent: TClass;
class function TObject.NewInstance: TObject;
begin
Result : = InitInstance(_GetMem(InstanceSize));
end ;
procedure TObject.FreeInstance;
begin
CleanupInstance;
_FreeMem(Self);
end ;
class function TObject.InstanceSize: Longint;
begin
Result : = PInteger(Integer(Self) + vmtInstanceSize)^;
end ;
constructor TObject.Create; // 空函数，编译器魔法，会自动调用ClassCreate插入分配内存的代码，真正的Create只是初始化数据而已
destructor TObject.Destroy; // 空函数
procedure TObject.Free; // 编译器魔法，在执行完Free方法之后，会自动插入BeforeDestruction和ClassDestroy函数来精确回收对象内存空间
begin
if Self <> nil then Destroy;
end ;
class function TObject.InitInstance(Instance: Pointer): TObject;
procedure TObject.CleanupInstance;
function InvokeImplGetter(Self: TObject; ImplGetter: Cardinal): IInterface;
function TObject.GetInterface( const IID: TGUID; out Obj): Boolean;
class function TObject.GetInterfaceEntry( const IID: TGUID): PInterfaceEntry;
class function TObject.GetInterfaceTable: PInterfaceTable;
function _IsClass(Child: TObject; Parent: TClass): Boolean;
function _AsClass(Child: TObject; Parent: TClass): TObject;
procedure GetDynaMethod;
procedure _CallDynaInst;
procedure _CallDynaClass;
procedure _FindDynaInst;
procedure _FindDynaClass;
class function TObject.InheritsFrom(AClass: TClass): Boolean;
class function TObject.ClassInfo: Pointer;
begin
Result : = PPointer(Integer(Self) + vmtTypeInfo)^;
end ;
function TObject.SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult;
begin
Result : = HResult($8000FFFF); { E_UNEXPECTED }
end ;
procedure TObject.DefaultHandler( var Message); // 空函数
procedure TObject.AfterConstruction; // 空函数，对Delphi没用，为C++ Builder保留
procedure TObject.BeforeDestruction; // 空函数，
procedure TObject.Dispatch( var Message);
asm
PUSH ESI
MOV SI,[EDX]
OR SI,SI
JE @@ default
CMP SI,0C000H
JAE @@ default
PUSH EAX
MOV EAX,[EAX]
CALL GetDynaMethod
POP EAX
JE @@ default
MOV ECX,ESI
POP ESI
JMP ECX
@@ default :
POP ESI
MOV ECX,[EAX]
JMP DWORD PTR [ECX] + VMTOFFSET TObject.DefaultHandler
end ;
class function TObject.MethodAddress( const Name: ShortString): Pointer;
class function TObject.MethodName(Address: Pointer): ShortString;
function TObject.FieldAddress( const Name: ShortString): Pointer;
function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject;
procedure _ClassDestroy(Instance: TObject);
function _AfterConstruction(Instance: TObject): TObject;
function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject;
{
The following NotifyXXXX routines are used to "raise" special exceptions
as a signaling mechanism to an interested debugger. If the debugger sets
the DebugHook flag to 1 or 2, then all exception processing is tracked by
raising these special exceptions. The debugger *MUST* respond to the
debug event with DBG_CONTINUE so that normal processing will occur.
}
{ tell the debugger that the next raise is a re-raise of the current non-Delphi
exception }
procedure NotifyReRaise;
{ tell the debugger about the raise of a non-Delphi exception }
procedure NotifyNonDelphiException;
{ Tell the debugger where the handler for the current exception is located }
procedure NotifyExcept;
procedure NotifyOnExcept;
procedure NotifyAnyExcept;
procedure CheckJmp;
{ Notify debugger of a finally during an exception unwind }
procedure NotifyExceptFinally;
{ Tell the debugger that the current exception is handled and cleaned up.
Also indicate where execution is about to resume. }
procedure NotifyTerminate;
{ Tell the debugger that there was no handler found for the current exception
and we are about to go to the default handler }
procedure NotifyUnhandled;
{ $IFDEF PC_MAPPED_EXCEPTIONS }
// MaybeCooptException
// If a Delphi exception is thrown from C++, a TRaisedException object
// will not be allocated yet on this side. We need to keep things sane,
// so we have to intercept such exceptions from the C++ side, and convert
// them so that they appear to have been thrown from this RTL. If we
// throw a Delphi exception, then we set the private _ 2 member of
// _Unwind_Exception to 0 . If C++ throws it, it sets it to the address
// of the throw point. We use this to distinguish the two cases, and
// adjust data structures as appropriate. On entry to this function ,
// EDX is the private _ 2 member, as set from SysRaiseException, and
// EAX is the exception object in question.
//
procedure MaybeCooptException;
function LinkException(Exc: PRaisedException): PRaisedException;
function UnlinkException: PRaisedException;
procedure _HandleAnyException;
{ $IFDEF PC_MAPPED_EXCEPTIONS }
{
Common code between the Win32 and PC mapped exception handling
scheme. This function takes a pointer to an object, and an exception
'on' descriptor table and finds the matching handler descriptor.
For support of Linux, we assume that EBX has been loaded with the GOT
that pertains to the code which is handling the exception currently.
If this function is being called from code which is not PIC, then
EBX should be zero on entry.
}
procedure FindOnExceptionDescEntry;
procedure _HandleOnExceptionPIC;
procedure _HandleOnException;
procedure _HandleFinally;
procedure _HandleAutoException;
procedure _RaiseAtExcept;
procedure _RaiseExcept;
procedure _ClassHandleException;
procedure _RaiseAgain;
{ $IFDEF PC_MAPPED_EXCEPTIONS }
{
This is implemented slow and dumb. The theory is that it is rare
to throw an exception past an except handler, and that the penalty
can be particularly high here. Partly it's done the dumb way for
the sake of maintainability. It could be inlined.
}
procedure _DestroyException;
procedure CleanupException;
procedure _DoneExcept;
procedure _TryFinallyExit;
var
InitContext: TInitContext;
{ $IFNDEF PC_MAPPED_EXCEPTIONS }
procedure MapToRunError(P: PExceptionRecord); stdcall ;
procedure _ExceptionHandler;
procedure SetExceptionHandler;
procedure UnsetExceptionHandler;
type
TProc = procedure ;
procedure FinalizeUnits;
const
errCaption: array [ 0 .. 5 ] of Char = ' Error ' # 0 ;
{ *********************************************************** }
procedure InitUnits;
procedure _PackageLoad( const Table : PackageInfo; Module: PLibModule);
procedure _PackageUnload( const Table : PackageInfo; Module: PLibModule);
procedure _StartExe(InitTable: PackageInfo; Module: PLibModule);
procedure _StartLib;
procedure _InitResStrings;
procedure _InitResStringImports;
procedure _InitImports;
procedure MakeErrorMessage;
procedure ExitDll;
procedure WriteErrorMessage;
var
RTLInitFailed: Boolean = False;
procedure _Halt0;
procedure _Halt;
procedure _Run0Error;
procedure _RunError(errorCode: Byte);
procedure _UnhandledException;
procedure _Assert( const Message, Filename: AnsiString; LineNumber: Integer);
type
PThreadRec = ^TThreadRec;
TThreadRec = record
Func: TThreadFunc;
Parameter: Pointer;
end ;
function ThreadWrapper(Parameter: Pointer): Integer; stdcall ;
{ $IFDEF MSWINDOWS }
function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord;
ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord;
var ThreadId: LongWord): Integer;
var
P: PThreadRec;
begin
New(P);
P.Func : = ThreadFunc;
P.Parameter : = Parameter;
IsMultiThread : = TRUE;
Result : = CreateThread(SecurityAttributes, StackSize, @ThreadWrapper, P,
CreationFlags, ThreadID);
end ;
procedure EndThread(ExitCode: Integer);
begin
ExitThread(ExitCode);
end ;
{ $ENDIF }
type
PStrRec = ^StrRec;
StrRec = packed record
refCnt: Longint;
length: Longint;
end ;
const
skew = SizeOf(StrRec);
rOff = SizeOf(StrRec); { refCnt offset }
overHead = SizeOf(StrRec) + 1 ;
procedure _LStrClr( var S);
procedure _LStrArrayClr( var StrArray; cnt: longint);
procedure _LStrAsg( var dest; const source);
procedure _LStrLAsg( var dest; const source);
function _NewAnsiString(length: Longint): Pointer;
procedure _LStrFromPCharLen( var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
function CharFromWChar(CharDest: PChar; DestBytes: Integer; const WCharSource: PWideChar; SrcChars: Integer): Integer;
function WCharFromChar(WCharDest: PWideChar; DestChars: Integer; const CharSource: PChar; SrcBytes: Integer): Integer;
procedure _LStrFromPWCharLen( var Dest: AnsiString; Source: PWideChar; Length: Integer);
procedure _LStrFromChar( var Dest: AnsiString; Source: AnsiChar);
procedure _LStrFromWChar( var Dest: AnsiString; Source: WideChar);
procedure _LStrFromPChar( var Dest: AnsiString; Source: PAnsiChar);
procedure _LStrFromPWChar( var Dest: AnsiString; Source: PWideChar);
procedure _LStrFromString( var Dest: AnsiString; const Source: ShortString);
procedure _LStrFromArray( var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
procedure _LStrFromWArray( var Dest: AnsiString; Source: PWideChar; Length: Integer);
procedure _LStrFromWStr( var Dest: AnsiString; const Source: WideString);
procedure _LStrToString { (var Dest: ShortString; const Source: AnsiString; MaxLen: Integer) } ;
function _LStrLen( const s: AnsiString): Longint;
procedure _LStrCat { var dest: AnsiString; source: AnsiString } ;
procedure _LStrCat3 { var dest:AnsiString; source1: AnsiString; source2: AnsiString } ;
procedure _LStrCatN { var dest:AnsiString; argCnt: Integer; ... } ;
procedure _LStrCmp { left: AnsiString; right: AnsiString } ;
function _LStrAddRef( var str): Pointer;
function PICEmptyString: PWideChar;
function _LStrToPChar( const s: AnsiString): PChar;
function InternalUniqueString( var str): Pointer;
procedure UniqueString( var str: AnsiString);
procedure _UniqueStringA( var str: AnsiString);
procedure UniqueString( var str: WideString);
procedure _UniqueStringW( var str: WideString);
procedure _LStrCopy { const s : AnsiString; index, count : Integer) : AnsiString } ;
procedure _LStrDelete { var s : AnsiString; index, count : Integer } ;
procedure _LStrInsert { const source : AnsiString; var s : AnsiString; index : Integer } ;
procedure _LStrPos { const substr : AnsiString; const s : AnsiString ) : Integer } ;
procedure _LStrSetLength { var str: AnsiString; newLength: Integer } ;
procedure _LStrOfChar { c: Char; count: Integer): AnsiString } ;
function _Write0LString( var t: TTextRec; const s: AnsiString): Pointer;
function _WriteLString( var t: TTextRec; const s: AnsiString; Longint): Pointer;
function _Write0WString( var t: TTextRec; const s: WideString): Pointer;
function _WriteWString( var t: TTextRec; const s: WideString; Longint): Pointer;
function _Write0WCString( var t: TTextRec; s: PWideChar): Pointer;
function _WriteWCString( var t: TTextRec; s: PWideChar; Longint): Pointer;
function _Write0WChar( var t: TTextRec; c: WideChar): Pointer;
function _WriteWChar( var t: TTextRec; c: WideChar; Integer): Pointer;
function _WriteVariant( var T: TTextRec; const V: TVarData; Width: Integer): Pointer;
function _Write0Variant( var T: TTextRec; const V: TVarData): Pointer;
function _NewWideString(CharLength: Longint): Pointer;
procedure WStrSet( var S: WideString; P: PWideChar);
procedure _WStrClr( var S);
procedure _WStrArrayClr( var StrArray; Count: Integer);
procedure _WStrAsg( var Dest: WideString; const Source: WideString);
procedure _WStrLAsg( var Dest: WideString; const Source: WideString);
procedure _WStrFromPCharLen( var Dest: WideString; Source: PAnsiChar; Length: Integer);
procedure _WStrFromPWCharLen( var Dest: WideString; Source: PWideChar; CharLength: Integer);
procedure _WStrFromChar( var Dest: WideString; Source: AnsiChar);
procedure _WStrFromWChar( var Dest: WideString; Source: WideChar);
procedure _WStrFromPChar( var Dest: WideString; Source: PAnsiChar);
procedure _WStrFromPWChar( var Dest: WideString; Source: PWideChar);
procedure _WStrFromString( var Dest: WideString; const Source: ShortString);
procedure _WStrFromArray( var Dest: WideString; Source: PAnsiChar; Length: Integer);
procedure _WStrFromWArray( var Dest: WideString; Source: PWideChar; Length: Integer);
procedure _WStrFromLStr( var Dest: WideString; const Source: AnsiString);
procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer);
function _WStrToPWChar( const S: WideString): PWideChar;
function _WStrLen( const S: WideString): Integer;
procedure _WStrCat( var Dest: WideString; const Source: WideString);
procedure _WStrCat3( var Dest: WideString; const Source1, Source2: WideString);
procedure _WStrCatN { var Dest: WideString; ArgCnt: Integer; ... } ;
procedure _WStrCmp { left: WideString; right: WideString } ;
function _WStrCopy( const S: WideString; Index, Count: Integer): WideString;
procedure _WStrDelete( var S: WideString; Index, Count: Integer);
procedure _WStrInsert( const Source: WideString; var Dest: WideString; Index: Integer);
procedure _WStrPos { const substr : WideString; const s : WideString ) : Integer } ;
procedure _WStrSetLength( var S: WideString; NewLength: Integer);
function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString;
function _WStrAddRef( var str: WideString): Pointer;
type
PPTypeInfo = ^PTypeInfo;
PTypeInfo = ^TTypeInfo;
TTypeInfo = packed record
Kind: Byte;
Name: ShortString;
{ TypeData: TTypeData }
end ;
TFieldInfo = packed record
TypeInfo: PPTypeInfo;
Offset: Cardinal;
end ;
PFieldTable = ^TFieldTable;
TFieldTable = packed record
X: Word;
Size: Cardinal;
Count: Cardinal;
Fields: array [ 0 .. 0 ] of TFieldInfo;
end ;
{ ===========================================================================
InitializeRecord, InitializeArray, and Initialize are PIC safe even though
they alter EBX because they only call each other. They never call out to
other functions and they don't access global data.
FinalizeRecord, Finalize, and FinalizeArray are PIC safe because they call
Pascal routines which will have EBX fixup prologs.
=========================================================================== }
procedure _InitializeRecord(p: Pointer; typeInfo: Pointer);
const
tkLString = 10 ;
tkWString = 11 ;
tkVariant = 12 ;
tkArray = 13 ;
tkRecord = 14 ;
tkInterface = 15 ;
tkDynArray = 17 ;
procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal);
procedure _Initialize(p: Pointer; typeInfo: Pointer);
procedure _FinalizeRecord(p: Pointer; typeInfo: Pointer);
procedure _VarClr( var v: TVarData);
procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal);
procedure _Finalize(p: Pointer; typeInfo: Pointer);
procedure _AddRefRecord { p: Pointer; typeInfo: Pointer } ;
procedure _VarAddRef( var v: TVarData);
procedure _AddRefArray { p: Pointer; typeInfo: Pointer; elemCount: Longint } ;
procedure _AddRef { p: Pointer; typeInfo: Pointer } ;
procedure _VarCopy( var Dest: TVarData; const Src: TVarData);
procedure _CopyRecord { dest, source, typeInfo: Pointer } ;
procedure _CopyObject { dest, source: Pointer; vmtPtrOffs: Longint; typeInfo: Pointer } ;
procedure _CopyArray { dest, source, typeInfo: Pointer; cnt: Integer } ;
function _New(size: Longint; typeInfo: Pointer): Pointer;
procedure _Dispose(p: Pointer; typeInfo: Pointer);
function WideCharToString(Source: PWideChar): string ;
function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string ;
procedure WideCharToStrVar(Source: PWideChar; var Dest: string );
procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer; var Dest: string );
function StringToWideChar( const Source: string ; Dest: PWideChar; DestSize: Integer): PWideChar;
function OleStrToString(Source: PWideChar): string ;
procedure OleStrToStrVar(Source: PWideChar; var Dest: string );
function StringToOleStr( const Source: string ): PWideChar;
procedure GetVariantManager( var VarMgr: TVariantManager);
procedure SetVariantManager( const VarMgr: TVariantManager);
function IsVariantManagerSet: Boolean;
procedure _IntfDispCall;
procedure _DispCallByIDError;
procedure _IntfVarCall;
procedure __llmul;
procedure __llmulo;
procedure __lldiv;
procedure __lldivo;
procedure __lludiv;
procedure __llmod;
procedure __llmodo;
procedure __llumod;
procedure __llshl;
procedure __llshr; // 64 - bit signed shift right
procedure __llushr; // 64 - bit unsigned shift right
function _StrInt64(val: Int64; Integer): ShortString;
function _Str0Int64(val: Int64): ShortString;
procedure _WriteInt64;
procedure _Write0Int64;
procedure _ReadInt64;
function _ValInt64( const s: AnsiString; var code: Integer): Int64;
procedure _DynArrayLength;
procedure _DynArrayHigh;
procedure CopyArray(dest, source, typeInfo: Pointer; cnt: Integer);
procedure FinalizeArray(p, typeInfo: Pointer; cnt: Integer);
procedure DynArrayClear( var a: Pointer; typeInfo: Pointer);
procedure DynArraySetLength( var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint);
procedure _DynArraySetLength;
procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer);
procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer);
procedure _DynArrayClear;
procedure _DynArrayAsg;
procedure _DynArrayAddRef;
function DynArrayIndex( const P: Pointer; const Indices: array of Integer; const TypInfo: Pointer): Pointer;
function DynArrayElTypeInfo(typeInfo: PDynArrayTypeInfo): PDynArrayTypeInfo;
function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer;
function DynArraySize(a: Pointer): Integer;
function IsDynArrayRectangular( const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): Boolean;
function DynArrayBounds( const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray;
function DecIndices( var Indices: TBoundArray; const Bounds: TBoundArray): Boolean;
{ Package/Module registration/unregistration }
const
LOCALE_SABBREVLANGNAME = $ 00000003 ; { abbreviated language name }
LOAD_LIBRARY_AS_DATAFILE = 2 ;
HKEY_CURRENT_USER = $ 80000001 ;
KEY_ALL_ACCESS = $000F003F;
KEY_READ = $000F0019;
OldLocaleOverrideKey = ' Software\Borland\Delphi\Locales ' ; // do not localize
NewLocaleOverrideKey = ' Software\Borland\Locales ' ; // do not localize
function FindModule(Instance: LongWord): PLibModule;
function FindHInstance(Address: Pointer): LongWord;
function FindClassHInstance(ClassType: TClass): LongWord;
function DelayLoadResourceModule(Module: PLibModule): LongWord;
function FindResourceHInstance(Instance: LongWord): LongWord;
function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean): LongWord;
procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); assembler ;
procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer);
procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer);
procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer);
procedure AddModuleUnloadProc(Proc: TModuleUnloadProc);
procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc);
procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW);
procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW);
procedure NotifyModuleUnload(HInstance: LongWord);
procedure RegisterModule(LibModule: PLibModule);
procedure UnregisterModule(LibModule: PLibModule);
function _IntfClear( var Dest: IInterface): Pointer;
procedure _IntfCopy( var Dest: IInterface; const Source: IInterface);
procedure _IntfCast( var Dest: IInterface; const Source: IInterface; const IID: TGUID);
procedure _IntfAddRef( const Dest: IInterface);
procedure TInterfacedObject.AfterConstruction;
procedure TInterfacedObject.BeforeDestruction;
class function TInterfacedObject.NewInstance: TObject;
function TInterfacedObject.QueryInterface( const IID: TGUID; out Obj): HResult;
function TInterfacedObject._AddRef: Integer;
function TInterfacedObject._Release: Integer;
{ TAggregatedObject }
constructor TAggregatedObject.Create( const Controller: IInterface);
function TAggregatedObject.GetController: IInterface;
function TAggregatedObject.QueryInterface( const IID: TGUID; out Obj): HResult;
function TAggregatedObject._AddRef: Integer;
function TAggregatedObject._Release: Integer; stdcall ;
function TContainedObject.QueryInterface( const IID: TGUID; out Obj): HResult;
function _CheckAutoResult(ResultCode: HResult): HResult;
function CompToDouble(Value: Comp): Double; cdecl ;
procedure DoubleToComp(Value: Double; var Result: Comp); cdecl ;
function CompToCurrency(Value: Comp): Currency; cdecl ;
procedure CurrencyToComp(Value: Currency; var Result: Comp); cdecl ;
function GetMemory(Size: Integer): Pointer; cdecl ;
function FreeMemory(P: Pointer): Integer; cdecl ;
function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl ;
procedure SetLineBreakStyle( var T: Text; Style: TTextLineBreakStyle);
function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer;
function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal;
function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer;
function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal;
function Utf8Encode( const WS: WideString): UTF8String;
function Utf8Decode( const S: UTF8String): WideString;
function AnsiToUtf8( const S: string ): UTF8String;
function Utf8ToAnsi( const S: UTF8String): string ;
function LoadResString(ResStringRec: PResStringRec): string ;
function PUCS4Chars( const S: UCS4String): PUCS4Char;
function WideStringToUCS4String( const S: WideString): UCS4String;
function UCS4StringToWidestring( const S: UCS4String): WideString;
function LCIDToCodePage(ALcid: LongWord): Integer;
const
CP_ACP = 0 ; // system default code page
LOCALE_IDEFAULTANSICODEPAGE = $ 00001004 ; // default ansi code page
var
ResultCode: Integer;
Buffer: array [ 0 .. 6 ] of Char;
begin
GetLocaleInfo(ALcid, LOCALE_IDEFAULTANSICODEPAGE, Buffer, SizeOf(Buffer));
Val(Buffer, Result, ResultCode);
if ResultCode <> 0 then
Result : = CP_ACP;
end ;
initialization
FileMode : = 2 ;
RaiseExceptionProc : = @RaiseException;
RTLUnwindProc : = @RTLUnwind;
Test8086 : = 2 ;
DispCallByIDProc : = @_DispCallByIDError;
if _isNECWindows then _FpuMaskInit;
_FpuInit();
TTextRec(Input).Mode : = fmClosed;
TTextRec(Output).Mode : = fmClosed;
TTextRec(ErrOutput).Mode : = fmClosed;
{ $IFDEF MSWINDOWS }
CmdLine : = GetCommandLine;
CmdShow : = GetCmdShow;
// High bit is set for Win95/ 98 / ME
if GetVersion and $ 80000000 <> $ 80000000 then
begin
if Lo(GetVersion) > 4 then
DefaultUserCodePage : = 3 // Use CP_THREAD_ACP with Win2K/ XP
else
// Use thread ' s current locale with NT4
DefaultUserCodePage := LCIDToCodePage(GetThreadLocale);
end
else
// Convert thread ' s current locale with Win95/98/ME
DefaultUserCodePage := LCIDToCodePage(GetThreadLocale);
{ $ENDIF }
MainThreadID : = GetCurrentThreadID;
finalization
Close(Input);
Close(Output);
Close(ErrOutput);
UninitAllocator;
end .
查看更多关于D7的System.pas单元的实现部分的详细内容...
声明：本文来自网络，不代表【好得很程序员自学网】立场，转载请注明出处：http://haodehen.cn/did48460