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, width: 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; width: Integer): Pointer; function _WriteBool(var t: TTextRec; val: Boolean; width: Longint): Pointer; function _Write0Bool(var t: TTextRec; val: Boolean): Pointer; function _WriteLong(var t: TTextRec; val, width: 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; width: Longint): Pointer; function _Write0CString(var t: TTextRec; s: PChar): Pointer; function _WriteCString(var t: TTextRec; s: PChar; width: 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; width: 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; width: Longint): Pointer; function _Write0WString(var t: TTextRec; const s: WideString): Pointer; function _WriteWString(var t: TTextRec; const s: WideString; width: Longint): Pointer; function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; function _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; function _Write0WChar(var t: TTextRec; c: WideChar): Pointer; function _WriteWChar(var t: TTextRec; c: WideChar; width: 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; width: 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.
